/[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 699 by dpavlin, Mon Sep 25 12:51:17 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;                  $log->debug("database: $database input = ", dump($input));
96                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;  
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->logdie("normalization input $full doesn't exist") unless (-e $full);  $log->warn("normalize = ",dump(@normalize));
106    
107                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  foreach my $normalize (@normalize) {
108    
109                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));                          my $path = $normalize->{path};
110                            return unless($path);
111                            my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
112    
113                  $log->debug("$database/$input_name: adding $path");                          $log->logdie("normalization input $full doesn't exist") unless (-e $full);
114    
115                  $self->{valid_inputs}->{$database}->{$input_name} = {                          my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
                         source => $s,  
                         path => $full,  
                         usage => 0,  
                 } unless defined($self->{valid_inputs}->{$database}->{$input_name});  
116    
117                  $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;                          my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
118    
119                  $nr++;                          $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");          $log->debug("found $nr source files");
# Line 111  sub read_sources { Line 139  sub read_sources {
139    
140    $parser->parse_lookups($database,$input);    $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_lookups {  sub parse_lookups {
149          my $self = shift;          my $self = shift;
150          my ($database, $input) = @_;          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("invalid database $database" ) unless $self->valid_database( $database );          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
# Line 209  sub parse_lookups { Line 243  sub parse_lookups {
243                          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] );
244                          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] );
245    
246                          $self->add_lookup_create( $e[3], $e[5], $create );                          # 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                            # 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 225  sub parse_lookups { Line 269  sub parse_lookups {
269                          $log->debug(">>> ", $Element->snext_sibling);                          $log->debug(">>> ", $Element->snext_sibling);
270          });          });
271    
272          my $source = $Document->serialize;          my $normalize_source = $Document->serialize;
273          $log->debug("create: ", dump($self->{_lookup_create}) );          $log->debug("create: ", dump($self->{_lookup_create}) );
274          $log->debug("normalize: $source");          $log->debug("normalize: $normalize_source");
275    
276          $self->{_normalize_source}->{$database}->{$input} = $source;          $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 );
# Line 241  sub parse_lookups { Line 285  sub parse_lookups {
285          return 1;          return 1;
286  }  }
287    
 =head2 add_lookup_create  
288    
289    $parse->add_lookup_create($database,$input,$source);  =head2 lookup_create_rules
290    
291      my $source = $parser->lookup_create_rules($database, $input);
292    
293  =cut  =cut
294    
295  sub add_lookup_create {  sub lookup_create_rules {
296          my $self = shift;          my $self = shift;
297          my ($database,$input,$source) = @_;          my ($database,$input) = @_;
298          $self->{_lookup_create}->{$database}->{$input} .= $source;          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 264  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 279  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          return defined($self->{valid_inputs}->{$database}->{$input});  =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      _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.692  
changed lines
  Added in v.699
  ViewVC Help
Powered by ViewVC 1.1.26