--- trunk/lib/WebPAC/Parser.pm 2006/09/24 17:25:04 686 +++ trunk/lib/WebPAC/Parser.pm 2006/09/25 12:51:47 701 @@ -3,13 +3,13 @@ use warnings; use strict; -use base qw/WebPAC::Common WebPAC::Normalize/; use PPI; use PPI::Dumper; use Data::Dump qw/dump/; use File::Slurp; +use base qw/WebPAC::Common WebPAC::Normalize/; =head1 NAME @@ -17,14 +17,24 @@ =head1 VERSION -Version 0.01 +Version 0.04 =cut -our $VERSION = '0.01'; +our $VERSION = '0.04'; =head1 SYNOPSIS +This module will parse L directives and generate source +to produce lookups and normalization. + +It's written using L, pure-perl parser for perl and heavily influenced by +reading about LISP. It might be a bit over-the board, but at least it removed +separate configuration files for lookups. + +This is experimental code, but it replaces all older formats which where, +at one point in time, available in WebPAC. + FIXME =head1 FUNCTIONS @@ -51,44 +61,106 @@ $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs')); - my $source; + $self->read_sources; + + $self ? return $self : return undef; +} + +=head2 read_sources + + my $source_files = $parser->read_sources; + +Called by L. + +=cut + +sub read_sources { + my $self = shift; + + my $log = $self->_get_logger(); + + my $nr = 0; + + my @lookups; $self->{config}->iterate_inputs( sub { - my $input = shift; - my $path = $input->{normalize}->{path} || return; - my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path; - $log->logdie("normalization input $full doesn't exist") unless (-e $full); - my $s = read_file( $full ) || $log->logdie("can't read $full: $!"); - $log->debug("adding $path to parser [",length($s)," bytes]"); - $source .= $s; + my ($input, $database) = @_; + + $log->debug("database: $database input = ", dump($input)); + + foreach my $normalize (@{ $input->{normalize} }) { + + my $path = $normalize->{path}; + return unless($path); + my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path; + + $log->logdie("normalization input $full doesn't exist") unless (-e $full); + + my $s = read_file( $full ) || $log->logdie("can't read $full: $!"); + + my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input )); + + $log->debug("$database/$input_name: adding $path"); + + $self->{valid_inputs}->{$database}->{$input_name}++; + + push @lookups, sub { + $self->parse_lookups( $database, $input_name, $full, $s ); + }; + + $nr++; + } } ); - $log->debug("collected ", length($source), " bytes of source"); + $log->debug("found $nr source files"); - $self->{source} = $source; + # parse all lookups + $_->() foreach (@lookups); - $self ? return $self : return undef; + return $nr; } -=head2 parse +=head2 parse_lookups + + $parser->parse_lookups($database,$input,$path,$source); + +Called for each normalize source in each input by L + +It will report invalid databases and inputs in error log after parsing. =cut -sub parse { +sub parse_lookups { my $self = shift; + my ($database, $input, $path, $source) = @_; + + $input = _input_name($input); my $log = $self->_get_logger(); - $log->logdie('no source found in object') unless ($self->{source}); + $log->logdie("invalid database $database" ) unless $self->valid_database( $database ); + $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input ); + + $log->logdie("no source found for database $database input $input path $path") unless ($source); + + $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)"); - 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}); $Document->prune('PPI::Token::Whitespace'); #$Document->prune('PPI::Token::Operator'); # Find all the named subroutines - my $eval_create; + $self->{_lookup_errors} = (); + + sub _lookup_error { + my $self = shift; + my $msg = shift; + $self->_get_logger->logconfess("error without message?") unless ($msg); + push @{ $self->{_lookup_errors} }, $msg; + return ''; + } $Document->find( sub { my ($Document,$Element) = @_; @@ -96,24 +168,28 @@ $Element->isa('PPI::Token::Word') or return ''; $Element->content eq 'lookup' or return ''; - print "#*** expansion: ", $Element->snext_sibling,$/; + $log->debug("expansion: ", $Element->snext_sibling); my $args = $Element->snext_sibling; my @e = $args->child(0)->elements; - 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); + + if ($log->is_debug) { + my $report = "found " . scalar @e . " elements:\n"; - print "# found ", scalar @e, " elements:\n"; + foreach my $i ( 0 .. $#e ) { + $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class ); + } - foreach my $i ( 0 .. $#e ) { - printf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class ); + $log->debug($report); } my $key_element = $e[8]->clone; - 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'); - print "## key part: ", $key_element, $/; + $log->debug("key part: ", $key_element); my @key; @@ -124,17 +200,17 @@ my $kf = $e->snext_sibling; - print "## key fragment = $kf\n"; + $log->debug("key fragment = $kf"); push @key, eval $kf; - print "ERROR: can't eval { $kf }: $@" if ($@); + $log->logdie("can't eval { $kf }: $@") if ($@); return 1; }); - my $key = join('-', @key ) || print "ERROR: no key found!"; + my $key = join('-', @key ) || $log->logdie("no key found!"); - print "key = $key\n"; + $log->debug("key = $key"); my $create = ' $coderef = ' . $e[7] . $e[8] . '; @@ -144,10 +220,22 @@ } '; - print "create: $create\n"; + $log->debug("create: $create"); + + return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] ); + return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] ); + + # save code to create this lookup + $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create; + - $create =~ s/\s+/ /gs; - $eval_create->{ $e[3] }->{ $e[5] } .= $create; + if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) } )) { + my $dep_key = $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }; + $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); + } + + # save this dependency + $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) } .= $key; if ($#e < 10) { $e[8]->insert_after( $e[8]->clone ); @@ -160,18 +248,120 @@ $e[8]->remove; - print "# >>> ", $Element->snext_sibling, "\n"; + $log->debug(">>> ", $Element->snext_sibling); }); - print "-----\ncreate: ", dump($eval_create), "\n"; - print "-----\nlookup: ", $Document->serialize, "\n"; - print "-----\n"; + my $normalize_source = $Document->serialize; + $log->debug("create: ", dump($self->{_lookup_create}) ); + $log->debug("normalize: $normalize_source"); + + $self->{_normalize_source}->{$database}->{$input} = $normalize_source; - my $Dumper = PPI::Dumper->new( $Document ); - $Dumper->print; + if ($self->{debug}) { + my $Dumper = PPI::Dumper->new( $Document ); + $Dumper->print; + } + $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors}); + + return 1; } + +=head2 lookup_create_rules + + my $source = $parser->lookup_create_rules($database, $input); + +=cut + +sub lookup_create_rules { + my $self = shift; + my ($database,$input) = @_; + return $self->{_lookup_create}->{ _q($database) }->{ _q($input) }; +} + +=head2 valid_database + + my $ok = $parse->valid_database('key'); + +=cut + +sub valid_database { + my $self = shift; + + my $database = shift || return; + + return defined($self->{valid_inputs}->{ _q($database) }); +} + +=head2 valid_database_input + + my $ok = $parse->valid_database('database_key','input_name'); + +=cut + +sub valid_database_input { + my $self = shift; + + my ($database,$input) = @_; + return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) }); +} + +=head2 depends + +Return all databases and inputs on which specified one depends + + $depends_on = $parser->depends('database','input'); + +=cut + +sub depends { + my $self = shift; + my ($database,$input) = @_; + $self->_get_logger->debug("depends($database,$input)"); + return unless ( + defined( $self->{depends}->{ _q($database) } ) && + defined( $self->{depends}->{ _q($database) }->{ _q($input) } ) + ); + return $self->{depends}->{ _q($database) }->{ _q($input) }; +} + +=head1 PRIVATE + +=head2 _q + +Strip single or double quotes around value + + _q(qq/'foo'/) -> foo + +=cut + +sub _q { + my $v = shift || return; + $v =~ s/^['"]*//g; + $v =~ s/['"]*$//g; + return $v; +} + +=head2 _input_name + +Return C value if HASH or arg if scalar + + _input_name($input) + +=cut + +sub _input_name { + my $input = shift || return; + if (ref($input) eq 'HASH') { + die "can't find 'name' value in ", dump($input) unless defined($input->{name}); + return $input->{name}; + } else { + return $input; + } +} + + =head1 AUTHOR Dobrica Pavlinusic, C<< >>