/[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 755 by dpavlin, Sun Oct 8 20:28:17 2006 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    =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    my $source_files = $parser->read_sources;  =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          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
242                  my ($input, $database) = @_;                  my ($input, $database) = @_;
243    
244                  my $path = $input->{normalize}->{path} || return;                  $log->debug("database: $database input = ", dump($input));
                 my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;  
245    
246                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  foreach my $normalize (@{ $input->{normalize} }) {
247    
248                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          my $path = $normalize->{path};
249                            return unless($path);
250                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
251    
252                  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);
253    
254                  $log->debug("$database/$input_name: adding $path");                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
255    
256                  $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});  
257    
258                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          $log->debug("$database/$input_name: adding $path");
259    
260                  $nr++;                          $self->{valid_inputs}->{$database}->{$input_name}++;
261    
262                            push @sources, sub {
263                                    $self->_parse_source( $database, $input_name, $full, $s );
264                            };
265    
266                            $nr++;
267                    }
268          } );          } );
269    
270          $log->debug("found $nr source files");          $log->debug("found $nr source files");
271    
272            # parse all sources
273            $_->() foreach (@sources);
274    
275          return $nr;          return $nr;
276  }  }
277    
278  =head2 parse_lookups  =head2 _parse_source
279    
280      $parser->_parse_source($database,$input,$path,$source);
281    
282    $parser->parse_lookups($database,$input);  Called for each normalize source (rules) in each input by L</_read_sources>
283    
284    It will report invalid databases and inputs in error log after parsing.
285    
286  =cut  =cut
287    
288  sub parse_lookups {  sub _parse_source {
289          my $self = shift;          my $self = shift;
290          my ($database, $input) = @_;          my ($database, $input, $path, $source) = @_;
291    
292            $input = _input_name($input);
293    
294          my $log = $self->_get_logger();          my $log = $self->_get_logger();
295    
296          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
297          $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 );
298    
         my $source = $self->{valid_inputs}->{$database}->{$input}->{source};  
         my $path = $self->{valid_inputs}->{$database}->{$input}->{path};  
   
299          $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);
300    
301          $log->info("parsing lookups for $database/$input from $path");          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
302    
303          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});
304    
305          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
306            $Document->prune('PPI::Token::Comment');
307          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
308    
309          # Find all the named subroutines          # Find all the named subroutines
# Line 196  sub parse_lookups { Line 368  sub parse_lookups {
368    
369                          $log->debug("key = $key");                          $log->debug("key = $key");
370    
371                          my $create = '                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
372                                  $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] );
373                                  foreach my $v ($coderef->()) {  
374                                          next unless (defined($v) && $v ne \'\');                          my $create = qq{
375                                          push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;                                  save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
376                                  }                          };
                         ';  
377    
378                          $log->debug("create: $create");                          $log->debug("create: $create");
379    
380                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );                          # save code to create this lookup
381                          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;
382                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
383    
384    
385                          $self->add_lookup_create( $e[3], $e[5], $create );                          if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
386                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
387                            }
388    
389                            # save this dependency
390                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
391    
392                          if ($#e < 10) {                          if ($#e < 10) {
393                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 225  sub parse_lookups { Line 403  sub parse_lookups {
403                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
404          });          });
405    
406          my $source = $Document->serialize;          my $normalize_source = $Document->serialize;
407          $log->debug("create: ", dump($self->{_lookup_create}) );          $log->debug("create: ", dump($self->{_lookup_create}) );
408          $log->debug("normalize: $source");          $log->debug("normalize: $normalize_source");
409    
410          $self->{_normalize_source}->{$database}->{$input} = $source;          $self->{_normalize_source}->{$database}->{$input} .= $normalize_source;
411    
412          if ($self->{debug}) {          if ($self->{debug}) {
413                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
# Line 238  sub parse_lookups { Line 416  sub parse_lookups {
416    
417          $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});
418    
419          return 1;          $Document->find( sub {
420  }                          my ($Document,$Element) = @_;
   
 =head2 add_lookup_create  
   
   $parse->add_lookup_create($database,$input,$source);  
421    
422  =cut                          $Element->isa('PPI::Token::Word') or return '';
423                            if ($Element->content =~ m/^(marc|search)/) {
424                                    my $what = $1;
425                                    $log->debug("found $what rules in $database/$input");
426                                    $self->{_have_rules}->{ $database }->{ $input }->{ $what }->{ $Element->content }++;
427                            } else {
428                                    return '';
429                            }
430            });
431    
432  sub add_lookup_create {          return 1;
         my $self = shift;  
         my ($database,$input,$source) = @_;  
         $self->{_lookup_create}->{$database}->{$input} .= $source;  
433  }  }
434    
435    
436  =head2 valid_database  =head2 _q
   
   my $ok = $parse->valid_database('key');  
437    
438  =cut  Strip single or double quotes around value
439    
440  sub valid_database {    _q(qq/'foo'/) -> foo
         my $self = shift;  
441    
442          my $database = shift || return;  =cut
         $database =~ s/['"]//g;  
443    
444          return defined($self->{valid_inputs}->{$database});  sub _q {
445            my $v = shift || return;
446            $v =~ s/^['"]*//g;
447            $v =~ s/['"]*$//g;
448            return $v;
449  }  }
450    
451  =head2 valid_database_input  =head2 _input_name
452    
453    my $ok = $parse->valid_database('database_key','input_name');  Return C<name> value if HASH or arg if scalar
454    
455  =cut    _input_name($input)
   
 sub valid_database_input {  
         my $self = shift;  
456    
457          my ($database,$input) = @_;  =cut
         $database =~ s/['"]//g;  
         $input =~ s/['"]//g;  
458    
459          return defined($self->{valid_inputs}->{$database}->{$input});  sub _input_name {
460            my $input = shift || return;
461            if (ref($input) eq 'HASH') {
462                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
463                    return $input->{name};
464            } else {
465                    return $input;
466            }
467  }  }
468    
469    
470  =head1 AUTHOR  =head1 AUTHOR
471    
472  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.692  
changed lines
  Added in v.755
  ViewVC Help
Powered by ViewVC 1.1.26