/[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 697 by dpavlin, Sun Sep 24 21:13:45 2006 UTC revision 698 by dpavlin, Mon Sep 25 11:14:53 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.04
21    
22  =cut  =cut
23    
24  our $VERSION = '0.03';  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 55  sub new { Line 65  sub new {
65    
66          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
67                  my ($input, $database) = @_;                  my ($input, $database) = @_;
68                  return unless $self->valid_database_input($database, $input->{name});                  return unless $self->valid_database_input($database, _input_name($input));
69                  $self->parse_lookups($database,$input->{name});                  $self->parse_lookups($database, _input_name($input));
70          } );          } );
71    
72          $self ? return $self : return undef;          $self ? return $self : return undef;
# Line 70  Called by L</new>. Line 80  Called by L</new>.
80    
81  =cut  =cut
82    
83    sub _input_name($);
84    
85  sub read_sources {  sub read_sources {
86          my $self = shift;          my $self = shift;
87    
# Line 80  sub read_sources { Line 92  sub read_sources {
92          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
93                  my ($input, $database) = @_;                  my ($input, $database) = @_;
94    
95                  my $path = $input->{normalize}->{path} || return;                  my @normalize;
96                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;  
97                    if (ref($input->{normalize}) eq 'ARRAY') {
98                            @normalize = @{ $input->{normalize} };
99                    } else {
100                            @normalize = ( $input->{normalize} );
101                    }
102    
103                    foreach my $normalize (@normalize) {
104    
105                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                          my $path = $normalize->{path};
106                            return unless($path);
107                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
108    
109                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                          $log->logdie("normalization input $full doesn't exist") unless (-e $full);
110    
111                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
112    
113                  $log->debug("$database/$input_name: adding $path");                          my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
114    
115                  $self->{valid_inputs}->{$database}->{$input_name} = {                          $log->debug("$database/$input_name: adding $path");
                         source => $s,  
                         path => $full,  
                         usage => 0,  
                 } unless defined($self->{valid_inputs}->{$database}->{$input_name});  
116    
117                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          $self->{valid_inputs}->{$database}->{$input_name} = {
118                                    source => $s,
119                                    path => $full,
120                                    usage => 0,
121                            } unless defined($self->{valid_inputs}->{$database}->{$input_name});
122    
123                  $nr++;                          $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;
124    
125                            $nr++;
126                    }
127          } );          } );
128    
129          $log->debug("found $nr source files");          $log->debug("found $nr source files");
# Line 111  sub read_sources { Line 135  sub read_sources {
135    
136    $parser->parse_lookups($database,$input);    $parser->parse_lookups($database,$input);
137    
138    Called for each input by L</new>
139    
140    It will report invalid databases and inputs in error log after parsing.
141    
142  =cut  =cut
143    
144  sub parse_lookups {  sub parse_lookups {
145          my $self = shift;          my $self = shift;
146          my ($database, $input) = @_;          my ($database, $input) = @_;
147    
148            $input = _input_name($input);
149    
150          my $log = $self->_get_logger();          my $log = $self->_get_logger();
151    
152          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
# Line 209  sub parse_lookups { Line 239  sub parse_lookups {
239                          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] );
240                          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] );
241    
242                          $self->add_lookup_create( $e[3], $e[5], $create );                          # save code to create this lookup
243                            $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create;
244    
245    
246                            if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) } )) {
247                                    my $dep_key = $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) };
248                                    $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);
249                            }
250    
251                            # save this dependency
252                            $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) } .= $key;
253    
254                          if ($#e < 10) {                          if ($#e < 10) {
255                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 241  sub parse_lookups { Line 281  sub parse_lookups {
281          return 1;          return 1;
282  }  }
283    
 =head2 add_lookup_create  
284    
285    $parse->add_lookup_create($database,$input,$source);  =head2 lookup_create_rules
286    
287      my $source = $parser->lookup_create_rules($database, $input);
288    
289  =cut  =cut
290    
291  sub add_lookup_create {  sub lookup_create_rules {
292          my $self = shift;          my $self = shift;
293          my ($database,$input,$source) = @_;          my ($database,$input) = @_;
294          $self->{_lookup_create}->{$database}->{$input} .= $source;          return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
295  }  }
296    
   
297  =head2 valid_database  =head2 valid_database
298    
299    my $ok = $parse->valid_database('key');    my $ok = $parse->valid_database('key');
# Line 264  sub valid_database { Line 304  sub valid_database {
304          my $self = shift;          my $self = shift;
305    
306          my $database = shift || return;          my $database = shift || return;
         $database =~ s/['"]//g;  
307    
308          return defined($self->{valid_inputs}->{$database});          return defined($self->{valid_inputs}->{ _q($database) });
309  }  }
310    
311  =head2 valid_database_input  =head2 valid_database_input
# Line 279  sub valid_database_input { Line 318  sub valid_database_input {
318          my $self = shift;          my $self = shift;
319    
320          my ($database,$input) = @_;          my ($database,$input) = @_;
321          $database =~ s/['"]//g;          return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
322          $input =~ s/['"]//g;  }
323    
324    =head2 depends
325    
326    Return all databases and inputs on which specified one depends
327    
328      $depends_on = $parser->depends('database','input');
329    
330    =cut
331    
332    sub depends {
333            my $self = shift;
334            my ($database,$input) = @_;
335            $self->_get_logger->debug("depends($database,$input)");
336            return unless defined( $self->{depends}->{ _q($database) }->{ _q($input) } );
337            return $self->{depends}->{ _q($database) }->{ _q($input) };
338    }
339    
340          return defined($self->{valid_inputs}->{$database}->{$input});  =head1 PRIVATE
341    
342    =head2 _q
343    
344    Strip single or double quotes around value
345    
346      _q(qq/'foo'/) -> foo
347    
348    =cut
349    
350    sub _q {
351            my $v = shift || return;
352            $v =~ s/^['"]*//g;
353            $v =~ s/['"]*$//g;
354            return $v;
355    }
356    
357    =head2 _input_name
358    
359    Return C<name> value if HASH or arg if scalar
360    
361      _input_name($input)
362    
363    =cut
364    
365    sub _input_name {
366            my $input = shift || return;
367            if (ref($input) eq 'HASH') {
368                    die "can't find 'name' value in ", dump($input) unless defined($input->{name});
369                    return $input->{name};
370            } else {
371                    return $input;
372            }
373  }  }
374    
375    
376  =head1 AUTHOR  =head1 AUTHOR
377    
378  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.697  
changed lines
  Added in v.698
  ViewVC Help
Powered by ViewVC 1.1.26