/[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 712 by dpavlin, Tue Sep 26 10:23:04 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    
# Line 17  WebPAC::Parser - parse perl normalizatio Line 17  WebPAC::Parser - parse perl normalizatio
17    
18  =head1 VERSION  =head1 VERSION
19    
20  Version 0.03  Version 0.05
21    
22  =cut  =cut
23    
24  our $VERSION = '0.03';  our $VERSION = '0.05';
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.
30    
31    It's written using L<PPI>, pure-perl parser for perl and heavily influenced by
32    reading about LISP. It might be a bit over-the board, but at least it removed
33    separate configuration files for lookups.
34    
35    This is experimental code, but it replaces all older formats which where,
36    at one point in time, available in WebPAC.
37    
38  FIXME  FIXME
39    
40  =head1 FUNCTIONS  =head1 FUNCTIONS
# Line 51  sub new { Line 61  sub new {
61    
62          $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'));
63    
64          $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});  
         } );  
65    
66          $self ? return $self : return undef;          $self ? return $self : return undef;
67  }  }
68    
69  =head2 read_sources  =head2 valid_database
70    
71      my $ok = $parse->valid_database('key');
72    
73    =cut
74    
75    sub valid_database {
76            my $self = shift;
77    
78            my $database = shift || return;
79    
80            return defined($self->{valid_inputs}->{ _q($database) });
81    }
82    
83    =head2 valid_database_input
84    
85      my $ok = $parse->valid_database('database_key','input_name');
86    
87    =cut
88    
89    sub valid_database_input {
90            my $self = shift;
91            my ($database,$input) = @_;
92            $input = _input_name($input);
93            return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
94    }
95    
96    =head2 depends
97    
98    Return all databases and inputs on which specified one depends
99    
100      $depends_on = $parser->depends('database','input');
101    
102    =cut
103    
104    sub depends {
105            my $self = shift;
106            my ($database,$input) = @_;
107            $input = _input_name($input);
108            $self->_get_logger->debug("depends($database,$input)");
109            return unless (
110                    defined( $self->{depends}->{ _q($database) } ) &&
111                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
112            );
113            return $self->{depends}->{ _q($database) }->{ _q($input) };
114    }
115    
116    =head2 have_lookup_create
117    
118      my @keys = $parser->have_lookup_create($database, $input);
119    
120    =cut
121    
122    sub have_lookup_create {
123            my $self = shift;
124            my ($database,$input) = @_;
125            $input = _input_name($input);
126            return unless (
127                    defined( $self->{_lookup_create_key}->{ _q($database) } ) &&
128                    defined( $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } )
129            );
130            return keys %{ $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } };
131    }
132    
133    
134    =head2 lookup_create_rules
135    
136      my $source = $parser->lookup_create_rules($database, $input);
137    
138    =cut
139    
140    sub lookup_create_rules {
141            my $self = shift;
142            my ($database,$input) = @_;
143            $input = _input_name($input);
144            return unless (
145                    defined( $self->{_lookup_create}->{ _q($database) } ) &&
146                    defined( $self->{_lookup_create}->{ _q($database) }->{ _q($input) } )
147            );
148            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
149    }
150    
151    =head1 PRIVATE
152    
153    =head2 _read_sources
154    
155    my $source_files = $parser->read_sources;    my $source_files = $parser->_read_sources;
156    
157  Called by L</new>.  Called by L</new>.
158    
159  =cut  =cut
160    
161  sub read_sources {  sub _read_sources {
162          my $self = shift;          my $self = shift;
163    
164          my $log = $self->_get_logger();          my $log = $self->_get_logger();
165    
166          my $nr = 0;          my $nr = 0;
167    
168            my @lookups;
169    
170          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
171                  my ($input, $database) = @_;                  my ($input, $database) = @_;
172    
173                  my $path = $input->{normalize}->{path} || return;                  $log->debug("database: $database input = ", dump($input));
                 my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;  
174    
175                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  foreach my $normalize (@{ $input->{normalize} }) {
176    
177                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          my $path = $normalize->{path};
178                            return unless($path);
179                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
180    
181                  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);
182    
183                  $log->debug("$database/$input_name: adding $path");                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
184    
185                  $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});  
186    
187                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          $log->debug("$database/$input_name: adding $path");
188    
189                  $nr++;                          $self->{valid_inputs}->{$database}->{$input_name}++;
190    
191                            push @lookups, sub {
192                                    $self->_parse_lookups( $database, $input_name, $full, $s );
193                            };
194    
195                            $nr++;
196                    }
197          } );          } );
198    
199          $log->debug("found $nr source files");          $log->debug("found $nr source files");
200    
201            # parse all lookups
202            $_->() foreach (@lookups);
203    
204          return $nr;          return $nr;
205  }  }
206    
207  =head2 parse_lookups  =head2 _parse_lookups
208    
209    $parser->parse_lookups($database,$input);    $parser->_parse_lookups($database,$input,$path,$source);
210    
211    Called for each normalize source (rules) in each input by L</_read_sources>
212    
213    It will report invalid databases and inputs in error log after parsing.
214    
215  =cut  =cut
216    
217  sub parse_lookups {  sub _parse_lookups {
218          my $self = shift;          my $self = shift;
219          my ($database, $input) = @_;          my ($database, $input, $path, $source) = @_;
220    
221            $input = _input_name($input);
222    
223          my $log = $self->_get_logger();          my $log = $self->_get_logger();
224    
225          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
226          $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 );
227    
         my $source = $self->{valid_inputs}->{$database}->{$input}->{source};  
         my $path = $self->{valid_inputs}->{$database}->{$input}->{path};  
   
228          $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);
229    
230          $log->info("parsing lookups for $database/$input from $path");          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
231    
232          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});
233    
# Line 196  sub parse_lookups { Line 296  sub parse_lookups {
296    
297                          $log->debug("key = $key");                          $log->debug("key = $key");
298    
299                          my $create = '                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
300                                  $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] );
301                                  foreach my $v ($coderef->()) {  
302                                          next unless (defined($v) && $v ne \'\');                          my $create = qq{
303                                          push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;                                  save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
304                                  }                          };
                         ';  
305    
306                          $log->debug("create: $create");                          $log->debug("create: $create");
307    
308                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );                          # save code to create this lookup
309                          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;
310                            $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
311    
312    
313                          $self->add_lookup_create( $e[3], $e[5], $create );                          if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
314                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
315                            }
316    
317                            # save this dependency
318                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
319    
320                          if ($#e < 10) {                          if ($#e < 10) {
321                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 225  sub parse_lookups { Line 331  sub parse_lookups {
331                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
332          });          });
333    
334          my $source = $Document->serialize;          my $normalize_source = $Document->serialize;
335          $log->debug("create: ", dump($self->{_lookup_create}) );          $log->debug("create: ", dump($self->{_lookup_create}) );
336          $log->debug("normalize: $source");          $log->debug("normalize: $normalize_source");
337    
338          $self->{_normalize_source}->{$database}->{$input} = $source;          $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
339    
340          if ($self->{debug}) {          if ($self->{debug}) {
341                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
# Line 241  sub parse_lookups { Line 347  sub parse_lookups {
347          return 1;          return 1;
348  }  }
349    
 =head2 add_lookup_create  
   
   $parse->add_lookup_create($database,$input,$source);  
   
 =cut  
   
 sub add_lookup_create {  
         my $self = shift;  
         my ($database,$input,$source) = @_;  
         $self->{_lookup_create}->{$database}->{$input} .= $source;  
 }  
350    
351    =head2 _q
352    
353  =head2 valid_database  Strip single or double quotes around value
354    
355    my $ok = $parse->valid_database('key');    _q(qq/'foo'/) -> foo
356    
357  =cut  =cut
358    
359  sub valid_database {  sub _q {
360          my $self = shift;          my $v = shift || return;
361            $v =~ s/^['"]*//g;
362          my $database = shift || return;          $v =~ s/['"]*$//g;
363          $database =~ s/['"]//g;          return $v;
   
         return defined($self->{valid_inputs}->{$database});  
364  }  }
365    
366  =head2 valid_database_input  =head2 _input_name
   
   my $ok = $parse->valid_database('database_key','input_name');  
367    
368  =cut  Return C<name> value if HASH or arg if scalar
369    
370  sub valid_database_input {    _input_name($input)
         my $self = shift;  
371    
372          my ($database,$input) = @_;  =cut
         $database =~ s/['"]//g;  
         $input =~ s/['"]//g;  
373    
374          return defined($self->{valid_inputs}->{$database}->{$input});  sub _input_name {
375            my $input = shift || return;
376            if (ref($input) eq 'HASH') {
377                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
378                    return $input->{name};
379            } else {
380                    return $input;
381            }
382  }  }
383    
384    
385  =head1 AUTHOR  =head1 AUTHOR
386    
387  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.692  
changed lines
  Added in v.712
  ViewVC Help
Powered by ViewVC 1.1.26