/[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 689 by dpavlin, Sun Sep 24 18:52:35 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.01  Version 0.02
21    
22  =cut  =cut
23    
24  our $VERSION = '0.01';  our $VERSION = '0.02';
25    
26  =head1 SYNOPSIS  =head1 SYNOPSIS
27    
# Line 54  sub new { Line 54  sub new {
54          my $source;          my $source;
55    
56          $self->{config}->iterate_inputs( sub {          $self->{config}->iterate_inputs( sub {
57                  my $input = shift;                  my ($input, $database) = @_;
58                  my $path = $input->{normalize}->{path} || return;                  my $path = $input->{normalize}->{path} || return;
59                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;                  my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
60                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);                  $log->logdie("normalization input $full doesn't exist") unless (-e $full);
61                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");                  my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
62                  $log->debug("adding $path to parser [",length($s)," bytes]");                  my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));
63                    $log->debug("$database/$input_name: adding $path to parser [",length($s)," bytes]");
64                  $source .= $s;                  $source .= $s;
65                    $self->{valid_inputs}->{$database}->{$input_name}++;
66          } );          } );
67    
68          $log->debug("collected ", length($source), " bytes of source");          $log->debug("collected ", length($source), " bytes of source");
# Line 81  sub parse { Line 83  sub parse {
83    
84          $log->logdie('no source found in object') unless ($self->{source});          $log->logdie('no source found in object') unless ($self->{source});
85    
86            $log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));
87    
88          my $Document = PPI::Document->new( \$self->{source} ) || $log->logdie("can't parse source:\n", $self->{source});          my $Document = PPI::Document->new( \$self->{source} ) || $log->logdie("can't parse source:\n", $self->{source});
89    
90          $Document->prune('PPI::Token::Whitespace');          $Document->prune('PPI::Token::Whitespace');
# Line 96  sub parse { Line 100  sub parse {
100                          $Element->isa('PPI::Token::Word') or return '';                          $Element->isa('PPI::Token::Word') or return '';
101                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
102    
103                          print "#*** expansion: ", $Element->snext_sibling,$/;                          $log->debug("expansion: ", $Element->snext_sibling);
104    
105                          my $args = $Element->snext_sibling;                          my $args = $Element->snext_sibling;
106                                    
107                          my @e = $args->child(0)->elements;                          my @e = $args->child(0)->elements;
108                          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);
109    
110                            if ($log->is_debug) {
111                                    my $report = "found " . scalar @e . " elements:\n";
112    
113                          print "# found ", scalar @e, " elements:\n";                                  foreach my $i ( 0 .. $#e ) {
114                                            $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
115                                    }
116    
117                          foreach my $i ( 0 .. $#e ) {                                  $log->debug($report);
                                 printf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );  
118                          }                          }
119    
120                          my $key_element = $e[8]->clone;                          my $key_element = $e[8]->clone;
121    
122                          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');
123    
124                          print "## key part: ", $key_element, $/;                          $log->debug("key part: ", $key_element);
125    
126                          my @key;                          my @key;
127    
# Line 124  sub parse { Line 132  sub parse {
132    
133                                  my $kf = $e->snext_sibling;                                  my $kf = $e->snext_sibling;
134    
135                                  print "## key fragment = $kf\n";                                  $log->debug("key fragment = $kf");
136    
137                                  push @key, eval $kf;                                  push @key, eval $kf;
138                                  print "ERROR: can't eval { $kf }: $@" if ($@);                                  $log->logdie("can't eval { $kf }: $@") if ($@);
139    
140                                  return 1;                                  return 1;
141                          });                          });
142    
143                          my $key = join('-', @key ) || print "ERROR: no key found!";                          my $key = join('-', @key ) || $log->logdie("no key found!");
144    
145                          print "key = $key\n";                          $log->debug("key = $key");
146    
147                          my $create = '                          my $create = '
148                                  $coderef = ' . $e[7] . $e[8] . ';                                  $coderef = ' . $e[7] . $e[8] . ';
# Line 144  sub parse { Line 152  sub parse {
152                                  }                                  }
153                          ';                          ';
154    
155                          print "create: $create\n";                          $log->debug("create: $create");
156    
157                            $log->logdie("invalid database $e[3]" ) unless $self->valid_database( $e[3] );
158                            $log->logdie("invalid input $e[5] of database $e[3]", ) unless $self->valid_database_input( $e[3], $e[5] );
159    
                         $create =~ s/\s+/ /gs;  
160                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;
161    
162                          if ($#e < 10) {                          if ($#e < 10) {
# Line 160  sub parse { Line 170  sub parse {
170                          $e[8]->remove;                          $e[8]->remove;
171    
172    
173                          print "# >>> ", $Element->snext_sibling, "\n";                          $log->debug(">>> ", $Element->snext_sibling);
174          });          });
175    
176          print "-----\ncreate: ", dump($eval_create), "\n";          $log->info("create: ", dump($eval_create) );
177          print "-----\nlookup: ", $Document->serialize, "\n";          $log->info("lookup: ", $Document->serialize );
178          print "-----\n";  
179            if ($self->{debug}) {
180                    my $Dumper = PPI::Dumper->new( $Document );
181                    $Dumper->print;
182            }
183    
184            return 1;
185    }
186    
187    =head2 valid_database
188    
189      my $ok = $parse->valid_database('key');
190    
191    =cut
192    
193    sub valid_database {
194            my $self = shift;
195    
196            my $database = shift || return;
197            $database =~ s/['"]//g;
198    
199            return defined($self->{valid_inputs}->{$database});
200    }
201    
202    =head2 valid_database_input
203    
204      my $ok = $parse->valid_database('database_key','input_name');
205    
206    =cut
207    
208    sub valid_database_input {
209            my $self = shift;
210    
211          my $Dumper = PPI::Dumper->new( $Document );          my ($database,$input) = @_;
212          $Dumper->print;          $database =~ s/['"]//g;
213            $input =~ s/['"]//g;
214    
215            return defined($self->{valid_inputs}->{$database}->{$input});
216  }  }
217    
218  =head1 AUTHOR  =head1 AUTHOR
Legend:
Removed from v.686  
changed lines
  Added in v.689
  ViewVC Help
Powered by ViewVC 1.1.26