/[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 690 by dpavlin, Sun Sep 24 19:00:56 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 89  sub parse { Line 93  sub parse {
93          # Find all the named subroutines          # Find all the named subroutines
94    
95          my $eval_create;          my $eval_create;
96            my @errors;
97    
98            sub error {
99                    my $msg = shift || $log->logconfess("error without message?");
100                    push @errors, $msg;
101                    return '';
102            }
103    
104          $Document->find( sub {          $Document->find( sub {
105                          my ($Document,$Element) = @_;                          my ($Document,$Element) = @_;
# Line 96  sub parse { Line 107  sub parse {
107                          $Element->isa('PPI::Token::Word') or return '';                          $Element->isa('PPI::Token::Word') or return '';
108                          $Element->content eq 'lookup' or return '';                          $Element->content eq 'lookup' or return '';
109    
110                          print "#*** expansion: ", $Element->snext_sibling,$/;                          $log->debug("expansion: ", $Element->snext_sibling);
111    
112                          my $args = $Element->snext_sibling;                          my $args = $Element->snext_sibling;
113                                    
114                          my @e = $args->child(0)->elements;                          my @e = $args->child(0)->elements;
115                          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);
116    
117                            if ($log->is_debug) {
118                                    my $report = "found " . scalar @e . " elements:\n";
119    
120                          print "# found ", scalar @e, " elements:\n";                                  foreach my $i ( 0 .. $#e ) {
121                                            $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
122                                    }
123    
124                          foreach my $i ( 0 .. $#e ) {                                  $log->debug($report);
                                 printf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );  
125                          }                          }
126    
127                          my $key_element = $e[8]->clone;                          my $key_element = $e[8]->clone;
128    
129                          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');
130    
131                          print "## key part: ", $key_element, $/;                          $log->debug("key part: ", $key_element);
132    
133                          my @key;                          my @key;
134    
# Line 124  sub parse { Line 139  sub parse {
139    
140                                  my $kf = $e->snext_sibling;                                  my $kf = $e->snext_sibling;
141    
142                                  print "## key fragment = $kf\n";                                  $log->debug("key fragment = $kf");
143    
144                                  push @key, eval $kf;                                  push @key, eval $kf;
145                                  print "ERROR: can't eval { $kf }: $@" if ($@);                                  $log->logdie("can't eval { $kf }: $@") if ($@);
146    
147                                  return 1;                                  return 1;
148                          });                          });
149    
150                          my $key = join('-', @key ) || print "ERROR: no key found!";                          my $key = join('-', @key ) || $log->logdie("no key found!");
151    
152                          print "key = $key\n";                          $log->debug("key = $key");
153    
154                          my $create = '                          my $create = '
155                                  $coderef = ' . $e[7] . $e[8] . ';                                  $coderef = ' . $e[7] . $e[8] . ';
# Line 144  sub parse { Line 159  sub parse {
159                                  }                                  }
160                          ';                          ';
161    
162                          print "create: $create\n";                          $log->debug("create: $create");
163    
164                            return error("invalid database $e[3]" ) unless $self->valid_database( $e[3] );
165                            return error("invalid input $e[5] of database $e[3]", ) unless $self->valid_database_input( $e[3], $e[5] );
166    
                         $create =~ s/\s+/ /gs;  
167                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;                          $eval_create->{ $e[3] }->{ $e[5] } .= $create;
168    
169                          if ($#e < 10) {                          if ($#e < 10) {
# Line 160  sub parse { Line 177  sub parse {
177                          $e[8]->remove;                          $e[8]->remove;
178    
179    
180                          print "# >>> ", $Element->snext_sibling, "\n";                          $log->debug(">>> ", $Element->snext_sibling);
181          });          });
182    
183          print "-----\ncreate: ", dump($eval_create), "\n";          $log->info("create: ", dump($eval_create) );
184          print "-----\nlookup: ", $Document->serialize, "\n";          $log->info("lookup: ", $Document->serialize );
185          print "-----\n";  
186            if ($self->{debug}) {
187                    my $Dumper = PPI::Dumper->new( $Document );
188                    $Dumper->print;
189            }
190    
191            $log->error("Parser errors: ", join("\n",@errors) ) if (@errors);
192    
193            return 1;
194    }
195    
196    =head2 valid_database
197    
198      my $ok = $parse->valid_database('key');
199    
200    =cut
201    
202    sub valid_database {
203            my $self = shift;
204    
205            my $database = shift || return;
206            $database =~ s/['"]//g;
207    
208            return defined($self->{valid_inputs}->{$database});
209    }
210    
211    =head2 valid_database_input
212    
213      my $ok = $parse->valid_database('database_key','input_name');
214    
215    =cut
216    
217    sub valid_database_input {
218            my $self = shift;
219    
220          my $Dumper = PPI::Dumper->new( $Document );          my ($database,$input) = @_;
221          $Dumper->print;          $database =~ s/['"]//g;
222            $input =~ s/['"]//g;
223    
224            return defined($self->{valid_inputs}->{$database}->{$input});
225  }  }
226    
227  =head1 AUTHOR  =head1 AUTHOR
Legend:
Removed from v.686  
changed lines
  Added in v.690
  ViewVC Help
Powered by ViewVC 1.1.26