/[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 689 by dpavlin, Sun Sep 24 18:52:35 2006 UTC revision 737 by dpavlin, Thu Oct 5 14:38:45 2006 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.07
21    
22  =cut  =cut
23    
24  our $VERSION = '0.02';  our $VERSION = '0.07';
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 generate_marc
173    
174      my $do_marc = $parser->generate_marc($database, $input);
175    
176    This function will return hash containing count of all found C<marc_*> directives.
177    
178    =cut
179    
180    sub generate_marc {
181            my $self = shift;
182            my ($database,$input) = @_;
183            $input = _input_name($input);
184            return unless (
185                    defined( $self->{_generate_marc}->{ _q($database) } ) &&
186                    defined( $self->{_generate_marc}->{ _q($database) }->{ _q($input) } )
187            );
188            return $self->{_generate_marc}->{ _q($database) }->{ _q($input) };
189    }
190    
191    
192    =head1 PRIVATE
193    
194    =head2 _read_sources
195    
196      my $source_files = $parser->_read_sources;
197    
198    Called by L</new>.
199    
200    =cut
201    
202    sub _read_sources {
203            my $self = shift;
204    
205            my $log = $self->_get_logger();
206    
207            my $nr = 0;
208    
209            my @sources;
210    
211          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
212                  my ($input, $database) = @_;                  my ($input, $database) = @_;
213                  my $path = $input->{normalize}->{path} || return;  
214                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  $log->debug("database: $database input = ", dump($input));
215                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);  
216                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  foreach my $normalize (@{ $input->{normalize} }) {
217                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));  
218                  $log->debug("$database/$input_name: adding $path to parser [",length($s)," bytes]");                          my $path = $normalize->{path};
219                  $source .= $s;                          return unless($path);
220                  $self->{valid_inputs}->{$database}->{$input_name}++;                          my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
221    
222                            $log->logdie("normalization input $full doesn't exist") unless (-e $full);
223    
224                            my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
225    
226                            my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
227    
228                            $log->debug("$database/$input_name: adding $path");
229    
230                            $self->{valid_inputs}->{$database}->{$input_name}++;
231    
232                            push @sources, sub {
233                                    $self->_parse_source( $database, $input_name, $full, $s );
234                            };
235    
236                            $nr++;
237                    }
238          } );          } );
239    
240          $log->debug("collected ", length($source), " bytes of source");          $log->debug("found $nr source files");
241    
242          $self->{source} = $source;          # parse all sources
243            $_->() foreach (@sources);
244    
245          $self ? return $self : return undef;          return $nr;
246  }  }
247    
248  =head2 parse  =head2 _parse_source
249    
250      $parser->_parse_source($database,$input,$path,$source);
251    
252    Called for each normalize source (rules) in each input by L</_read_sources>
253    
254    It will report invalid databases and inputs in error log after parsing.
255    
256  =cut  =cut
257    
258  sub parse {  sub _parse_source {
259          my $self = shift;          my $self = shift;
260            my ($database, $input, $path, $source) = @_;
261    
262            $input = _input_name($input);
263    
264          my $log = $self->_get_logger();          my $log = $self->_get_logger();
265    
266          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
267            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
268    
269            $log->logdie("no source found for database $database input $input path $path") unless ($source);
270    
271          $log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
272    
273          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});
274    
275          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
276            $Document->prune('PPI::Token::Comment');
277          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
278    
279          # Find all the named subroutines          # Find all the named subroutines
280    
281          my $eval_create;          $self->{_lookup_errors} = ();
282    
283            sub _lookup_error {
284                    my $self = shift;
285                    my $msg = shift;
286                    $self->_get_logger->logconfess("error without message?") unless ($msg);
287                    push @{ $self->{_lookup_errors} }, $msg;
288                    return '';
289            }
290    
291          $Document->find( sub {          $Document->find( sub {
292                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 144  sub parse { Line 338  sub parse {
338    
339                          $log->debug("key = $key");                          $log->debug("key = $key");
340    
341                          my $create = '                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
342                                  $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] );
343                                  foreach my $v ($coderef->()) {  
344                                          next unless (defined($v) && $v ne \'\');                          my $create = qq{
345                                          push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;                                  save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
346                                  }                          };
                         ';  
347    
348                          $log->debug("create: $create");                          $log->debug("create: $create");
349    
350                          $log->logdie("invalid database $e[3]" ) unless $self->valid_database( $e[3] );                          # save code to create this lookup
351                          $log->logdie("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;
352                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
353    
354                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;  
355                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
356                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
357                            }
358    
359                            # save this dependency
360                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
361    
362                          if ($#e < 10) {                          if ($#e < 10) {
363                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 173  sub parse { Line 373  sub parse {
373                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
374          });          });
375    
376          $log->info("create: ", dump($eval_create) );          my $normalize_source = $Document->serialize;
377          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
378            $log->debug("normalize: $normalize_source");
379    
380            $self->{_normalize_source}->{$database}->{$input} .= $normalize_source;
381    
382          if ($self->{debug}) {          if ($self->{debug}) {
383                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
384                  $Dumper->print;                  $Dumper->print;
385          }          }
386    
387            $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
388    
389            $Document->find( sub {
390                            my ($Document,$Element) = @_;
391    
392                            $Element->isa('PPI::Token::Word') or return '';
393                            $Element->content =~ m/^marc/ or return '';
394    
395                            $log->debug("found marc output generation for $database/$input");
396                            $self->{_generate_marc}->{ $database }->{ $input }->{ $Element->content }++;
397            });
398    
399          return 1;          return 1;
400  }  }
401    
 =head2 valid_database  
402    
403    my $ok = $parse->valid_database('key');  =head2 _q
404    
405  =cut  Strip single or double quotes around value
406    
407  sub valid_database {    _q(qq/'foo'/) -> foo
         my $self = shift;  
408    
409          my $database = shift || return;  =cut
         $database =~ s/['"]//g;  
410    
411          return defined($self->{valid_inputs}->{$database});  sub _q {
412            my $v = shift || return;
413            $v =~ s/^['"]*//g;
414            $v =~ s/['"]*$//g;
415            return $v;
416  }  }
417    
418  =head2 valid_database_input  =head2 _input_name
   
   my $ok = $parse->valid_database('database_key','input_name');  
419    
420  =cut  Return C<name> value if HASH or arg if scalar
421    
422  sub valid_database_input {    _input_name($input)
         my $self = shift;  
423    
424          my ($database,$input) = @_;  =cut
         $database =~ s/['"]//g;  
         $input =~ s/['"]//g;  
425    
426          return defined($self->{valid_inputs}->{$database}->{$input});  sub _input_name {
427            my $input = shift || return;
428            if (ref($input) eq 'HASH') {
429                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
430                    return $input->{name};
431            } else {
432                    return $input;
433            }
434  }  }
435    
436    
437  =head1 AUTHOR  =head1 AUTHOR
438    
439  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.689  
changed lines
  Added in v.737
  ViewVC Help
Powered by ViewVC 1.1.26