/[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 826 by dpavlin, Sun May 20 16:19:13 2007 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 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          $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});  
         } );  
68    
69          $self ? return $self : return undef;          $self ? return $self : return undef;
70  }  }
71    
72  =head2 read_sources  =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    my $source_files = $parser->read_sources;  =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>.  Called by L</new>.
229    
230  =cut  =cut
231    
232  sub read_sources {  sub _read_sources {
233          my $self = shift;          my $self = shift;
234    
235          my $log = $self->_get_logger();          my $log = $self->_get_logger();
236    
237          my $nr = 0;          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    
246                  my $path = $input->{normalize}->{path} || return;                  $log->debug("database: $database input = ", dump($input));
                 my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;  
247    
248                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  foreach my $normalize (@{ $input->{normalize} }) {
249    
250                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          my $path = $normalize->{path};
251                            return unless($path);
252                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
253    
254                  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);
255    
256                  $log->debug("$database/$input_name: adding $path");                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
257    
258                  $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});  
259    
260                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          $log->debug("$database/$input_name: adding $path");
261    
262                  $nr++;                          $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("found $nr source files");          $log->debug("found $nr source files");
274    
275            # parse all sources
276            $_->() foreach (@sources);
277    
278          return $nr;          return $nr;
279  }  }
280    
281  =head2 parse_lookups  =head2 _parse_source
282    
283      $parser->_parse_source($database,$input,$path,$source);
284    
285    $parser->parse_lookups($database,$input);  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_lookups {  sub _parse_source {
292          my $self = shift;          my $self = shift;
293          my ($database, $input) = @_;          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("invalid database $database" ) unless $self->valid_database( $database );          $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 );          $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
301    
         my $source = $self->{valid_inputs}->{$database}->{$input}->{source};  
         my $path = $self->{valid_inputs}->{$database}->{$input}->{path};  
   
302          $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);
303    
304          $log->info("parsing lookups for $database/$input from $path");          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
305    
306          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});
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
# Line 196  sub parse_lookups { Line 371  sub parse_lookups {
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 $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );                          # save code to create this lookup
384                          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;
385                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
386    
387    
388                          $self->add_lookup_create( $e[3], $e[5], $create );                          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 225  sub parse_lookups { Line 406  sub parse_lookups {
406                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
407          });          });
408    
409          my $source = $Document->serialize;          my $normalize_source = $Document->serialize;
410          $log->debug("create: ", dump($self->{_lookup_create}) );          $log->debug("create: ", dump($self->{_lookup_create}) );
411          $log->debug("normalize: $source");          $log->debug("normalize: $normalize_source");
412    
413          $self->{_normalize_source}->{$database}->{$input} = $source;          $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 );
# Line 238  sub parse_lookups { Line 419  sub parse_lookups {
419    
420          $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});
421    
422          return 1;          $Document->find( sub {
423  }                          my ($Document,$Element) = @_;
   
 =head2 add_lookup_create  
   
   $parse->add_lookup_create($database,$input,$source);  
424    
425  =cut                          $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  sub add_lookup_create {          return 1;
         my $self = shift;  
         my ($database,$input,$source) = @_;  
         $self->{_lookup_create}->{$database}->{$input} .= $source;  
436  }  }
437    
438    
439  =head2 valid_database  =head2 _q
   
   my $ok = $parse->valid_database('key');  
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
455    
456    my $ok = $parse->valid_database('database_key','input_name');  Return C<name> value if HASH or arg if scalar
457    
458  =cut    _input_name($input)
   
 sub valid_database_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.692  
changed lines
  Added in v.826
  ViewVC Help
Powered by ViewVC 1.1.26