/[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 691 by dpavlin, Sun Sep 24 21:13:36 2006 UTC revision 703 by dpavlin, Mon Sep 25 13:24:09 2006 UTC
# 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 lookup_create_rules
70    
71      my $source = $parser->lookup_create_rules($database, $input);
72    
73    =cut
74    
75    sub lookup_create_rules {
76            my $self = shift;
77            my ($database,$input) = @_;
78            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
79    }
80    
81    =head2 valid_database
82    
83      my $ok = $parse->valid_database('key');
84    
85    =cut
86    
87    sub valid_database {
88            my $self = shift;
89    
90            my $database = shift || return;
91    
92            return defined($self->{valid_inputs}->{ _q($database) });
93    }
94    
95    =head2 valid_database_input
96    
97      my $ok = $parse->valid_database('database_key','input_name');
98    
99    =cut
100    
101    sub valid_database_input {
102            my $self = shift;
103    
104            my ($database,$input) = @_;
105            return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
106    }
107    
108    =head2 depends
109    
110    my $source_files = $parser->read_sources;  Return all databases and inputs on which specified one depends
111    
112      $depends_on = $parser->depends('database','input');
113    
114    =cut
115    
116    sub depends {
117            my $self = shift;
118            my ($database,$input) = @_;
119            $self->_get_logger->debug("depends($database,$input)");
120            return unless (
121                    defined( $self->{depends}->{ _q($database) } ) &&
122                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
123            );
124            return $self->{depends}->{ _q($database) }->{ _q($input) };
125    }
126    
127    =head1 PRIVATE
128    
129    =head2 _read_sources
130    
131      my $source_files = $parser->_read_sources;
132    
133  Called by L</new>.  Called by L</new>.
134    
135  =cut  =cut
136    
137  sub read_sources {  sub _read_sources {
138          my $self = shift;          my $self = shift;
139    
140          my $log = $self->_get_logger();          my $log = $self->_get_logger();
141    
142          my $nr = 0;          my $nr = 0;
143    
144            my @lookups;
145    
146          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
147                  my ($input, $database) = @_;                  my ($input, $database) = @_;
148    
149                  my $path = $input->{normalize}->{path} || return;                  $log->debug("database: $database input = ", dump($input));
150                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;  
151                    foreach my $normalize (@{ $input->{normalize} }) {
152    
153                            my $path = $normalize->{path};
154                            return unless($path);
155                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
156    
157                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                          $log->logdie("normalization input $full doesn't exist") unless (-e $full);
158    
159                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
160    
161                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));                          my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
162    
163                  $log->debug("$database/$input_name: adding $path");                          $log->debug("$database/$input_name: adding $path");
164    
165                  $self->{valid_inputs}->{$database}->{$input_name} = {                          $self->{valid_inputs}->{$database}->{$input_name}++;
                         source => $s,  
                         path => $full,  
                         usage => 0,  
                 } unless defined($self->{valid_inputs}->{$database}->{$input_name});  
166    
167                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          push @lookups, sub {
168                                    $self->_parse_lookups( $database, $input_name, $full, $s );
169                            };
170    
171                  $nr++;                          $nr++;
172                    }
173          } );          } );
174    
175          $log->debug("found $nr source files");          $log->debug("found $nr source files");
176    
177            # parse all lookups
178            $_->() foreach (@lookups);
179    
180          return $nr;          return $nr;
181  }  }
182    
183  =head2 parse_lookup  =head2 _parse_lookups
184    
185      $parser->_parse_lookups($database,$input,$path,$source);
186    
187    $parser->parse_lookups($database,$input);  Called for each normalize source (rules) in each input by L</read_sources>
188    
189    It will report invalid databases and inputs in error log after parsing.
190    
191  =cut  =cut
192    
193  sub parse_lookups {  sub _parse_lookups {
194          my $self = shift;          my $self = shift;
195          my ($database, $input) = @_;          my ($database, $input, $path, $source) = @_;
196    
197            $input = _input_name($input);
198    
199          my $log = $self->_get_logger();          my $log = $self->_get_logger();
200    
201          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
202          $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 );
203    
         my $source = $self->{valid_inputs}->{$database}->{$input}->{source};  
         my $path = $self->{valid_inputs}->{$database}->{$input}->{path};  
   
204          $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);
205    
206          $log->info("parsing lookups for $database/$input in $path");          $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
207    
208          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});
209    
# Line 136  sub parse_lookups { Line 212  sub parse_lookups {
212    
213          # Find all the named subroutines          # Find all the named subroutines
214    
         my $eval_create;  
215          $self->{_lookup_errors} = ();          $self->{_lookup_errors} = ();
216    
217          sub _lookup_error {          sub _lookup_error {
# Line 210  sub parse_lookups { Line 285  sub parse_lookups {
285                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
286                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );                          return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
287    
288                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          # save code to create this lookup
289                            $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create;
290    
291    
292                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
293                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
294                            }
295    
296                            # save this dependency
297                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
298    
299                          if ($#e < 10) {                          if ($#e < 10) {
300                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 226  sub parse_lookups { Line 310  sub parse_lookups {
310                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
311          });          });
312    
313          $log->info("create: ", dump($eval_create) );          my $normalize_source = $Document->serialize;
314          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
315            $log->debug("normalize: $normalize_source");
316    
317            $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
318    
319          if ($self->{debug}) {          if ($self->{debug}) {
320                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
321                  $Dumper->print;                  $Dumper->print;
322          }          }
323    
324          $log->error("Parser errors: ", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});          $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
325    
326          return 1;          return 1;
327  }  }
328    
 =head2 valid_database  
329    
330    my $ok = $parse->valid_database('key');  =head2 _q
331    
332  =cut  Strip single or double quotes around value
333    
334  sub valid_database {    _q(qq/'foo'/) -> foo
         my $self = shift;  
335    
336          my $database = shift || return;  =cut
         $database =~ s/['"]//g;  
337    
338          return defined($self->{valid_inputs}->{$database});  sub _q {
339            my $v = shift || return;
340            $v =~ s/^['"]*//g;
341            $v =~ s/['"]*$//g;
342            return $v;
343  }  }
344    
345  =head2 valid_database_input  =head2 _input_name
346    
347    my $ok = $parse->valid_database('database_key','input_name');  Return C<name> value if HASH or arg if scalar
348    
349  =cut    _input_name($input)
   
 sub valid_database_input {  
         my $self = shift;  
350    
351          my ($database,$input) = @_;  =cut
         $database =~ s/['"]//g;  
         $input =~ s/['"]//g;  
352    
353          return defined($self->{valid_inputs}->{$database}->{$input});  sub _input_name {
354            my $input = shift || return;
355            if (ref($input) eq 'HASH') {
356                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
357                    return $input->{name};
358            } else {
359                    return $input;
360            }
361  }  }
362    
363    
364  =head1 AUTHOR  =head1 AUTHOR
365    
366  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.691  
changed lines
  Added in v.703
  ViewVC Help
Powered by ViewVC 1.1.26