/[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 686 by dpavlin, Sun Sep 24 17:25:04 2006 UTC revision 692 by dpavlin, Sun Sep 24 21:13:40 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.01  Version 0.03
21    
22  =cut  =cut
23    
24  our $VERSION = '0.01';  our $VERSION = '0.03';
25    
26  =head1 SYNOPSIS  =head1 SYNOPSIS
27    
# Line 51  sub new { Line 51  sub new {
51    
52          $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'));
53    
54          my $source;          $self->read_sources;
55    
56            $self->{config}->iterate_inputs( sub {
57                    my ($input, $database) = @_;
58                    return unless $self->valid_database_input($database, $input->{name});
59                    $self->parse_lookups($database,$input->{name});
60            } );
61    
62            $self ? return $self : return undef;
63    }
64    
65    =head2 read_sources
66    
67      my $source_files = $parser->read_sources;
68    
69    Called by L</new>.
70    
71    =cut
72    
73    sub read_sources {
74            my $self = shift;
75    
76            my $log = $self->_get_logger();
77    
78            my $nr = 0;
79    
80          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
81                  my $input = shift;                  my ($input, $database) = @_;
82    
83                  my $path = $input->{normalize}->{path} || return;                  my $path = $input->{normalize}->{path} || return;
84                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
85    
86                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);
87    
88                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
                 $log->debug("adding $path to parser [",length($s)," bytes]");  
                 $source .= $s;  
         } );  
89    
90          $log->debug("collected ", length($source), " bytes of source");                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));
91    
92          $self->{source} = $source;                  $log->debug("$database/$input_name: adding $path");
93    
94          $self ? return $self : return undef;                  $self->{valid_inputs}->{$database}->{$input_name} = {
95                            source => $s,
96                            path => $full,
97                            usage => 0,
98                    } unless defined($self->{valid_inputs}->{$database}->{$input_name});
99    
100                    $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;
101    
102                    $nr++;
103            } );
104    
105            $log->debug("found $nr source files");
106    
107            return $nr;
108  }  }
109    
110  =head2 parse  =head2 parse_lookups
111    
112      $parser->parse_lookups($database,$input);
113    
114  =cut  =cut
115    
116  sub parse {  sub parse_lookups {
117          my $self = shift;          my $self = shift;
118            my ($database, $input) = @_;
119    
120          my $log = $self->_get_logger();          my $log = $self->_get_logger();
121    
122          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
123            $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
124    
125            my $source = $self->{valid_inputs}->{$database}->{$input}->{source};
126            my $path = $self->{valid_inputs}->{$database}->{$input}->{path};
127    
128            $log->logdie("no source found for database $database input $input path $path") unless ($source);
129    
130            $log->info("parsing lookups for $database/$input from $path");
131    
132          my $Document = PPI::Document->new( \$self->{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});
133    
134          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
135          #$Document->prune('PPI::Token::Operator');          #$Document->prune('PPI::Token::Operator');
136    
137          # Find all the named subroutines          # Find all the named subroutines
138    
139          my $eval_create;          $self->{_lookup_errors} = ();
140    
141            sub _lookup_error {
142                    my $self = shift;
143                    my $msg = shift;
144                    $self->_get_logger->logconfess("error without message?") unless ($msg);
145                    push @{ $self->{_lookup_errors} }, $msg;
146                    return '';
147            }
148    
149          $Document->find( sub {          $Document->find( sub {
150                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 96  sub parse { Line 152  sub parse {
152                          $Element->isa('PPI::Token::Word') or return '';                          $Element->isa('PPI::Token::Word') or return '';
153                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
154    
155                          print "#*** expansion: ", $Element->snext_sibling,$/;                          $log->debug("expansion: ", $Element->snext_sibling);
156    
157                          my $args = $Element->snext_sibling;                          my $args = $Element->snext_sibling;
158                                    
159                          my @e = $args->child(0)->elements;                          my @e = $args->child(0)->elements;
160                          print "hum, expect at least 8 elements, got ", scalar @e, " in $args\n" if ($#e < 8);                          $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
161    
162                            if ($log->is_debug) {
163                                    my $report = "found " . scalar @e . " elements:\n";
164    
165                          print "# found ", scalar @e, " elements:\n";                                  foreach my $i ( 0 .. $#e ) {
166                                            $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
167                                    }
168    
169                          foreach my $i ( 0 .. $#e ) {                                  $log->debug($report);
                                 printf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );  
170                          }                          }
171    
172                          my $key_element = $e[8]->clone;                          my $key_element = $e[8]->clone;
173    
174                          die "key element must be PPI::Structure::Block" unless $key_element->isa('PPI::Structure::Block');                          $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
175    
176                          print "## key part: ", $key_element, $/;                          $log->debug("key part: ", $key_element);
177    
178                          my @key;                          my @key;
179    
# Line 124  sub parse { Line 184  sub parse {
184    
185                                  my $kf = $e->snext_sibling;                                  my $kf = $e->snext_sibling;
186    
187                                  print "## key fragment = $kf\n";                                  $log->debug("key fragment = $kf");
188    
189                                  push @key, eval $kf;                                  push @key, eval $kf;
190                                  print "ERROR: can't eval { $kf }: $@" if ($@);                                  $log->logdie("can't eval { $kf }: $@") if ($@);
191    
192                                  return 1;                                  return 1;
193                          });                          });
194    
195                          my $key = join('-', @key ) || print "ERROR: no key found!";                          my $key = join('-', @key ) || $log->logdie("no key found!");
196    
197                          print "key = $key\n";                          $log->debug("key = $key");
198    
199                          my $create = '                          my $create = '
200                                  $coderef = ' . $e[7] . $e[8] . ';                                  $coderef = ' . $e[7] . $e[8] . ';
# Line 144  sub parse { Line 204  sub parse {
204                                  }                                  }
205                          ';                          ';
206    
207                          print "create: $create\n";                          $log->debug("create: $create");
208    
209                            return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
210                            return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
211    
212                          $create =~ s/\s+/ /gs;                          $self->add_lookup_create( $e[3], $e[5], $create );
                         $eval_create->{ $e[3] }->{ $e[5] } .= $create;  
213    
214                          if ($#e < 10) {                          if ($#e < 10) {
215                                  $e[8]->insert_after( $e[8]->clone );                                  $e[8]->insert_after( $e[8]->clone );
# Line 160  sub parse { Line 222  sub parse {
222                          $e[8]->remove;                          $e[8]->remove;
223    
224    
225                          print "# >>> ", $Element->snext_sibling, "\n";                          $log->debug(">>> ", $Element->snext_sibling);
226          });          });
227    
228          print "-----\ncreate: ", dump($eval_create), "\n";          my $source = $Document->serialize;
229          print "-----\nlookup: ", $Document->serialize, "\n";          $log->debug("create: ", dump($self->{_lookup_create}) );
230          print "-----\n";          $log->debug("normalize: $source");
231    
232            $self->{_normalize_source}->{$database}->{$input} = $source;
233    
234            if ($self->{debug}) {
235                    my $Dumper = PPI::Dumper->new( $Document );
236                    $Dumper->print;
237            }
238    
239            $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
240    
241            return 1;
242    }
243    
244    =head2 add_lookup_create
245    
246      $parse->add_lookup_create($database,$input,$source);
247    
248    =cut
249    
250    sub add_lookup_create {
251            my $self = shift;
252            my ($database,$input,$source) = @_;
253            $self->{_lookup_create}->{$database}->{$input} .= $source;
254    }
255    
256    
257    =head2 valid_database
258    
259      my $ok = $parse->valid_database('key');
260    
261    =cut
262    
263    sub valid_database {
264            my $self = shift;
265    
266            my $database = shift || return;
267            $database =~ s/['"]//g;
268    
269            return defined($self->{valid_inputs}->{$database});
270    }
271    
272    =head2 valid_database_input
273    
274      my $ok = $parse->valid_database('database_key','input_name');
275    
276    =cut
277    
278    sub valid_database_input {
279            my $self = shift;
280    
281          my $Dumper = PPI::Dumper->new( $Document );          my ($database,$input) = @_;
282          $Dumper->print;          $database =~ s/['"]//g;
283            $input =~ s/['"]//g;
284    
285            return defined($self->{valid_inputs}->{$database}->{$input});
286  }  }
287    
288  =head1 AUTHOR  =head1 AUTHOR
Legend:
Removed from v.686  
changed lines
  Added in v.692
  ViewVC Help
Powered by ViewVC 1.1.26