/[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 690 by dpavlin, Sun Sep 24 19:00:56 2006 UTC revision 826 by dpavlin, Sun May 20 16:19:13 2007 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.02  Version 0.08
21    
22  =cut  =cut
23    
24  our $VERSION = '0.02';  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 51  sub new { Line 64  sub new {
64    
65          $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'));
66    
67          my $source;          $self->_read_sources;
68    
69            $self ? return $self : return undef;
70    }
71    
72    =head2 valid_database
73    
74      my $ok = $parse->valid_database('key');
75    
76    =cut
77    
78    sub valid_database {
79            my $self = shift;
80    
81            my $database = shift || return;
82    
83            return defined($self->{valid_inputs}->{ _q($database) });
84    }
85    
86    =head2 valid_database_input
87    
88      my $ok = $parse->valid_database('database_key','input_name');
89    
90    =cut
91    
92    sub valid_database_input {
93            my $self = shift;
94            my ($database,$input) = @_;
95            $input = _input_name($input);
96            return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
97    }
98    
99    =head2 depends
100    
101    Return all databases and inputs on which specified one depends
102    
103      $depends_on = $parser->depends('database','input');
104    
105    =cut
106    
107    sub depends {
108            my $self = shift;
109            my ($database,$input) = @_;
110            $input = _input_name($input);
111            $self->_get_logger->debug("depends($database,$input)");
112            return unless (
113                    defined( $self->{depends}->{ _q($database) } ) &&
114                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
115            );
116            return $self->{depends}->{ _q($database) }->{ _q($input) };
117    }
118    
119    =head2 have_lookup_create
120    
121      my @keys = $parser->have_lookup_create($database, $input);
122    
123    =cut
124    
125    sub have_lookup_create {
126            my $self = shift;
127            my ($database,$input) = @_;
128            $input = _input_name($input);
129            return unless (
130                    defined( $self->{_lookup_create_key}->{ _q($database) } ) &&
131                    defined( $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } )
132            );
133            return keys %{ $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } };
134    }
135    
136    
137    =head2 lookup_create_rules
138    
139      my $source = $parser->lookup_create_rules($database, $input);
140    
141    =cut
142    
143    sub lookup_create_rules {
144            my $self = shift;
145            my ($database,$input) = @_;
146            $input = _input_name($input);
147            return unless (
148                    defined( $self->{_lookup_create}->{ _q($database) } ) &&
149                    defined( $self->{_lookup_create}->{ _q($database) }->{ _q($input) } )
150            );
151            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
152    }
153    
154    =head2 normalize_rules
155    
156      my $source = $parser->normalize_rules($database, $input);
157    
158    =cut
159    
160    sub normalize_rules {
161            my $self = shift;
162            my ($database,$input) = @_;
163            $input = _input_name($input);
164            return unless (
165                    defined( $self->{_normalize_source}->{ _q($database) } ) &&
166                    defined( $self->{_normalize_source}->{ _q($database) }->{ _q($input) } )
167            );
168            return $self->{_normalize_source}->{ _q($database) }->{ _q($input) };
169    }
170    
171    
172    =head2 have_rules
173    
174      my $do_marc = $parser->have_rules('marc', $database, $input);
175      my $do_index = $parser->have_rules('search', $database);
176    
177    This function will return hash containing count of all found C<marc_*> or
178    C<search> directives. Input name is optional.
179    
180    =cut
181    
182    sub have_rules {
183            my $self = shift;
184    
185            my $log = $self->_get_logger();
186            my $type = shift @_ || $log->logconfess("need at least type");
187            my $database = shift @_ || $log->logconfess("database is required");
188            my $input = shift @_;
189    
190            $input = _input_name($input);
191    
192    
193            return unless defined( $self->{_have_rules}->{ _q($database) } );
194    
195            my $database_rules = $self->{_have_rules}->{ _q($database ) };
196    
197            if (defined($input)) {
198    
199                    return unless (
200                            defined( $database_rules->{ _q($input) } ) &&
201                            defined( $database_rules->{ _q($input) }->{ $type } )
202                    );
203    
204                    return $database_rules->{ _q($input) }->{ $type };
205            }
206    
207            my $usage;
208    
209            foreach my $i (keys %{ $database_rules }) {
210                    next unless defined( $database_rules->{$i}->{$type} );
211    
212                    foreach my $t (keys %{ $database_rules->{ $i }->{$type} }) {
213                            $usage->{ $t } += $database_rules->{ $i }->{ $t };
214                    }
215            }
216    
217            return $usage;
218    
219    }
220    
221    
222    =head1 PRIVATE
223    
224    =head2 _read_sources
225    
226      my $source_files = $parser->_read_sources;
227    
228    Called by L</new>.
229    
230    =cut
231    
232    sub _read_sources {
233            my $self = shift;
234    
235            my $log = $self->_get_logger();
236    
237            my $nr = 0;
238    
239            my @sources;
240    
241            my $lookup_src_cache;
242    
243          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
244                  my ($input, $database) = @_;                  my ($input, $database) = @_;
245                  my $path = $input->{normalize}->{path} || return;  
246                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  $log->debug("database: $database input = ", dump($input));
247                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);  
248                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  foreach my $normalize (@{ $input->{normalize} }) {
249                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));  
250                  $log->debug("$database/$input_name: adding $path to parser [",length($s)," bytes]");                          my $path = $normalize->{path};
251                  $source .= $s;                          return unless($path);
252                  $self->{valid_inputs}->{$database}->{$input_name}++;                          my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
253    
254                            $log->logdie("normalization input $full doesn't exist") unless (-e $full);
255    
256                            my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
257    
258                            my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
259    
260                            $log->debug("$database/$input_name: adding $path");
261    
262                            $self->{valid_inputs}->{$database}->{$input_name}++;
263    
264                            push @sources, sub {
265                                    #warn "### $database $input_name, $full ###\n";
266                                    $self->_parse_source( $database, $input_name, $full, $s );
267                            };
268    
269                            $nr++;
270                    }
271          } );          } );
272    
273          $log->debug("collected ", length($source), " bytes of source");          $log->debug("found $nr source files");
274    
275          $self->{source} = $source;          # parse all sources
276            $_->() foreach (@sources);
277    
278          $self ? return $self : return undef;          return $nr;
279  }  }
280    
281  =head2 parse  =head2 _parse_source
282    
283      $parser->_parse_source($database,$input,$path,$source);
284    
285    Called for each normalize source (rules) in each input by L</_read_sources>
286    
287    It will report invalid databases and inputs in error log after parsing.
288    
289  =cut  =cut
290    
291  sub parse {  sub _parse_source {
292          my $self = shift;          my $self = shift;
293            my ($database, $input, $path, $source) = @_;
294    
295            $input = _input_name($input);
296    
297          my $log = $self->_get_logger();          my $log = $self->_get_logger();
298    
299          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
300            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
301    
302            $log->logdie("no source found for database $database input $input path $path") unless ($source);
303    
304          $log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
305    
306          my $Document = PPI::Document->new( \$self->{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});
307    
308          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
309            $Document->prune('PPI::Token::Comment');
310          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
311    
312          # Find all the named subroutines          # Find all the named subroutines
313    
314          my $eval_create;          $self->{_lookup_errors} = ();
         my @errors;  
315    
316          sub error {          sub _lookup_error {
317                  my $msg = shift || $log->logconfess("error without message?");                  my $self = shift;
318                  push @errors, $msg;                  my $msg = shift;
319                    $self->_get_logger->logconfess("error without message?") unless ($msg);
320                    push @{ $self->{_lookup_errors} }, $msg;
321                  return '';                  return '';
322          }          }
323    
# Line 151  sub parse { Line 371  sub parse {
371    
372                          $log->debug("key = $key");                          $log->debug("key = $key");
373    
374                          my $create = '                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
375                                  $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] );
376                                  foreach my $v ($coderef->()) {  
377                                          next unless (defined($v) && $v ne \'\');                          my $create = qq{
378                                          push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;                                  save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
379                                  }                          };
                         ';  
380    
381                          $log->debug("create: $create");                          $log->debug("create: $create");
382    
383                          return error("invalid database $e[3]" ) unless $self->valid_database( $e[3] );                          # save code to create this lookup
384                          return error("invalid input $e[5] of database $e[3]", ) unless $self->valid_database_input( $e[3], $e[5] );                          $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create;
385                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
386    
387                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;  
388                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
389                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
390                            }
391    
392                            # save this dependency
393                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
394    
395                          if ($#e < 10) {                          if ($#e < 10) {
396                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 180  sub parse { Line 406  sub parse {
406                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
407          });          });
408    
409          $log->info("create: ", dump($eval_create) );          my $normalize_source = $Document->serialize;
410          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
411            $log->debug("normalize: $normalize_source");
412    
413            $self->{_normalize_source}->{$database}->{$input} .= $normalize_source;
414    
415          if ($self->{debug}) {          if ($self->{debug}) {
416                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
417                  $Dumper->print;                  $Dumper->print;
418          }          }
419    
420          $log->error("Parser errors: ", join("\n",@errors) ) if (@errors);          $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
421    
422            $Document->find( sub {
423                            my ($Document,$Element) = @_;
424    
425                            $Element->isa('PPI::Token::Word') or return '';
426                            if ($Element->content =~ m/^(marc|search)/) {
427                                    my $what = $1;
428                                    $log->debug("found $what rules in $database/$input");
429                                    $self->{_have_rules}->{ $database }->{ $input }->{ $what }->{ $Element->content }++;
430                            } else {
431                                    return '';
432                            }
433            });
434    
435          return 1;          return 1;
436  }  }
437    
 =head2 valid_database  
438    
439    my $ok = $parse->valid_database('key');  =head2 _q
440    
441  =cut  Strip single or double quotes around value
442    
443  sub valid_database {    _q(qq/'foo'/) -> foo
         my $self = shift;  
444    
445          my $database = shift || return;  =cut
         $database =~ s/['"]//g;  
446    
447          return defined($self->{valid_inputs}->{$database});  sub _q {
448            my $v = shift || return;
449            $v =~ s/^['"]*//g;
450            $v =~ s/['"]*$//g;
451            return $v;
452  }  }
453    
454  =head2 valid_database_input  =head2 _input_name
   
   my $ok = $parse->valid_database('database_key','input_name');  
455    
456  =cut  Return C<name> value if HASH or arg if scalar
457    
458  sub valid_database_input {    _input_name($input)
         my $self = shift;  
459    
460          my ($database,$input) = @_;  =cut
         $database =~ s/['"]//g;  
         $input =~ s/['"]//g;  
461    
462          return defined($self->{valid_inputs}->{$database}->{$input});  sub _input_name {
463            my $input = shift || return;
464            if (ref($input) eq 'HASH') {
465                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
466                    return $input->{name};
467            } else {
468                    return $input;
469            }
470  }  }
471    
472    
473  =head1 AUTHOR  =head1 AUTHOR
474    
475  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.690  
changed lines
  Added in v.826
  ViewVC Help
Powered by ViewVC 1.1.26