/[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 690 by dpavlin, Sun Sep 24 19:00:56 2006 UTC revision 699 by dpavlin, Mon Sep 25 12:51:17 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 WebPAC::Normalize/;
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.02  Version 0.04
21    
22  =cut  =cut
23    
24  our $VERSION = '0.02';  our $VERSION = '0.04';
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          my $source;          $self->read_sources;
65    
66          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
67                  my ($input, $database) = @_;                  my ($input, $database) = @_;
68                  my $path = $input->{normalize}->{path} || return;                  return unless $self->valid_database_input($database, _input_name($input));
69                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  $self->parse_lookups($database, _input_name($input));
                 $log->logdie("normalization input $full doesn't exist") unless (-e $full);  
                 my $s = read_file( $full ) || $log->logdie("can't read $full: $!");  
                 my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));  
                 $log->debug("$database/$input_name: adding $path to parser [",length($s)," bytes]");  
                 $source .= $s;  
                 $self->{valid_inputs}->{$database}->{$input_name}++;  
70          } );          } );
71    
72          $log->debug("collected ", length($source), " bytes of source");          $self ? return $self : return undef;
73    }
74    
75          $self->{source} = $source;  =head2 read_sources
76    
77          $self ? return $self : return undef;    my $source_files = $parser->read_sources;
78    
79    Called by L</new>.
80    
81    =cut
82    
83    sub _input_name($);
84    
85    sub read_sources {
86            my $self = shift;
87    
88            my $log = $self->_get_logger();
89    
90            my $nr = 0;
91    
92            $self->{config}->iterate_inputs( sub {
93                    my ($input, $database) = @_;
94    
95                    $log->debug("database: $database input = ", dump($input));
96    
97                    my @normalize;
98    
99                    if (ref($input->{normalize}) eq 'ARRAY') {
100                            @normalize = @{ $input->{normalize} };
101                    } else {
102                            @normalize = ( $input->{normalize} );
103                    }
104    
105    $log->warn("normalize = ",dump(@normalize));
106    
107                    foreach my $normalize (@normalize) {
108    
109                            my $path = $normalize->{path};
110                            return unless($path);
111                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
112    
113                            $log->logdie("normalization input $full doesn't exist") unless (-e $full);
114    
115                            my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
116    
117                            my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
118    
119                            $log->debug("$database/$input_name: adding $path");
120    
121                            $self->{valid_inputs}->{$database}->{$input_name} = {
122                                    source => $s,
123                                    path => $full,
124                                    usage => 0,
125                            } unless defined($self->{valid_inputs}->{$database}->{$input_name});
126    
127                            $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;
128    
129                            $nr++;
130                    }
131            } );
132    
133            $log->debug("found $nr source files");
134    
135            return $nr;
136  }  }
137    
138  =head2 parse  =head2 parse_lookups
139    
140      $parser->parse_lookups($database,$input);
141    
142    Called for each input by L</new>
143    
144    It will report invalid databases and inputs in error log after parsing.
145    
146  =cut  =cut
147    
148  sub parse {  sub parse_lookups {
149          my $self = shift;          my $self = shift;
150            my ($database, $input) = @_;
151    
152            $input = _input_name($input);
153    
154          my $log = $self->_get_logger();          my $log = $self->_get_logger();
155    
156          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
157            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
158    
159            my $source = $self->{valid_inputs}->{$database}->{$input}->{source};
160            my $path = $self->{valid_inputs}->{$database}->{$input}->{path};
161    
162          $log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));          $log->logdie("no source found for database $database input $input path $path") unless ($source);
163    
164          my $Document = PPI::Document->new( \$self->{source} ) || $log->logdie("can't parse source:\n", $self->{source});          $log->info("parsing lookups for $database/$input from $path");
165    
166            my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});
167    
168          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
169          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
170    
171          # Find all the named subroutines          # Find all the named subroutines
172    
173          my $eval_create;          $self->{_lookup_errors} = ();
         my @errors;  
174    
175          sub error {          sub _lookup_error {
176                  my $msg = shift || $log->logconfess("error without message?");                  my $self = shift;
177                  push @errors, $msg;                  my $msg = shift;
178                    $self->_get_logger->logconfess("error without message?") unless ($msg);
179                    push @{ $self->{_lookup_errors} }, $msg;
180                  return '';                  return '';
181          }          }
182    
# Line 161  sub parse { Line 240  sub parse {
240    
241                          $log->debug("create: $create");                          $log->debug("create: $create");
242    
243                          return error("invalid database $e[3]" ) unless $self->valid_database( $e[3] );                          return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
244                          return error("invalid input $e[5] of database $e[3]", ) 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] );
245    
246                            # save code to create this lookup
247                            $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create;
248    
249    
250                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) } )) {
251                                    my $dep_key = $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) };
252                                    $log->warn("dependency of $database/$input on $e[3]/$e[5] allready recorded as $dep_key, now changed to $key") if ($dep_key ne $key);
253                            }
254    
255                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          # save this dependency
256                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) } .= $key;
257    
258                          if ($#e < 10) {                          if ($#e < 10) {
259                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 180  sub parse { Line 269  sub parse {
269                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
270          });          });
271    
272          $log->info("create: ", dump($eval_create) );          my $normalize_source = $Document->serialize;
273          $log->info("lookup: ", $Document->serialize );          $log->debug("create: ", dump($self->{_lookup_create}) );
274            $log->debug("normalize: $normalize_source");
275    
276            $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
277    
278          if ($self->{debug}) {          if ($self->{debug}) {
279                  my $Dumper = PPI::Dumper->new( $Document );                  my $Dumper = PPI::Dumper->new( $Document );
280                  $Dumper->print;                  $Dumper->print;
281          }          }
282    
283          $log->error("Parser errors: ", join("\n",@errors) ) if (@errors);          $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
284    
285          return 1;          return 1;
286  }  }
287    
288    
289    =head2 lookup_create_rules
290    
291      my $source = $parser->lookup_create_rules($database, $input);
292    
293    =cut
294    
295    sub lookup_create_rules {
296            my $self = shift;
297            my ($database,$input) = @_;
298            return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
299    }
300    
301  =head2 valid_database  =head2 valid_database
302    
303    my $ok = $parse->valid_database('key');    my $ok = $parse->valid_database('key');
# Line 203  sub valid_database { Line 308  sub valid_database {
308          my $self = shift;          my $self = shift;
309    
310          my $database = shift || return;          my $database = shift || return;
         $database =~ s/['"]//g;  
311    
312          return defined($self->{valid_inputs}->{$database});          return defined($self->{valid_inputs}->{ _q($database) });
313  }  }
314    
315  =head2 valid_database_input  =head2 valid_database_input
# Line 218  sub valid_database_input { Line 322  sub valid_database_input {
322          my $self = shift;          my $self = shift;
323    
324          my ($database,$input) = @_;          my ($database,$input) = @_;
325          $database =~ s/['"]//g;          return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
326          $input =~ s/['"]//g;  }
327    
328    =head2 depends
329    
330    Return all databases and inputs on which specified one depends
331    
332      $depends_on = $parser->depends('database','input');
333    
334    =cut
335    
336    sub depends {
337            my $self = shift;
338            my ($database,$input) = @_;
339            $self->_get_logger->debug("depends($database,$input)");
340            return unless (
341                    defined( $self->{depends}->{ _q($database) } ) &&
342                    defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
343            );
344            return $self->{depends}->{ _q($database) }->{ _q($input) };
345    }
346    
347    =head1 PRIVATE
348    
349    =head2 _q
350    
351    Strip single or double quotes around value
352    
353      _q(qq/'foo'/) -> foo
354    
355    =cut
356    
357    sub _q {
358            my $v = shift || return;
359            $v =~ s/^['"]*//g;
360            $v =~ s/['"]*$//g;
361            return $v;
362    }
363    
364    =head2 _input_name
365    
366    Return C<name> value if HASH or arg if scalar
367    
368          return defined($self->{valid_inputs}->{$database}->{$input});    _input_name($input)
369    
370    =cut
371    
372    sub _input_name {
373            my $input = shift || return;
374            if (ref($input) eq 'HASH') {
375                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
376                    return $input->{name};
377            } else {
378                    return $input;
379            }
380  }  }
381    
382    
383  =head1 AUTHOR  =head1 AUTHOR
384    
385  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.690  
changed lines
  Added in v.699
  ViewVC Help
Powered by ViewVC 1.1.26