--- trunk/lib/WebPAC/Parser.pm 2006/09/25 16:07:08 708 +++ trunk/lib/WebPAC/Parser.pm 2009/08/19 16:24:43 1277 @@ -13,20 +13,23 @@ =head1 NAME -WebPAC::Parser - parse perl normalization configuration files and mungle it +WebPAC::Parser - parse perl normalization configuration files (rules) and mungle it =head1 VERSION -Version 0.05 +Version 0.08 =cut -our $VERSION = '0.05'; +our $VERSION = '0.08'; =head1 SYNOPSIS This module will parse L directives and generate source -to produce lookups and normalization. +to produce lookups and normalization. It will also parse other parts of +source to produce some of DWIM (I) magic +(like producing MARC oputput using L if there are C +rules in normalisation). 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 @@ -46,6 +49,7 @@ my $parser = new WebPAC::Parser( config => new WebPAC::Config(), base_path => '/optional/path/to/conf', + only_database => $only ); =cut @@ -148,6 +152,74 @@ return $self->{_lookup_create}->{ _q($database) }->{ _q($input) }; } +=head2 normalize_rules + + my $source = $parser->normalize_rules($database, $input); + +=cut + +sub normalize_rules { + my $self = shift; + my ($database,$input) = @_; + $input = _input_name($input); + return unless ( + defined( $self->{_normalize_source}->{ _q($database) } ) && + defined( $self->{_normalize_source}->{ _q($database) }->{ _q($input) } ) + ); + return $self->{_normalize_source}->{ _q($database) }->{ _q($input) }; +} + + +=head2 have_rules + + my $do_marc = $parser->have_rules('marc', $database, $input); + my $do_index = $parser->have_rules('search', $database); + +This function will return hash containing count of all found C or +C directives. Input name is optional. + +=cut + +sub have_rules { + my $self = shift; + + my $log = $self->_get_logger(); + my $type = shift @_ || $log->logconfess("need at least type"); + my $database = shift @_ || $log->logconfess("database is required"); + my $input = shift @_; + + $input = _input_name($input); + + + return unless defined( $self->{_have_rules}->{ _q($database) } ); + + my $database_rules = $self->{_have_rules}->{ _q($database ) }; + + if (defined($input)) { + + return unless ( + defined( $database_rules->{ _q($input) } ) && + defined( $database_rules->{ _q($input) }->{ $type } ) + ); + + return $database_rules->{ _q($input) }->{ $type }; + } + + my $usage; + + foreach my $i (keys %{ $database_rules }) { + next unless defined( $database_rules->{$i}->{$type} ); + + foreach my $t (keys %{ $database_rules->{ $i }->{$type} }) { + $usage->{ $t } += $database_rules->{ $i }->{ $t }; + } + } + + return $usage; + +} + + =head1 PRIVATE =head2 _read_sources @@ -165,11 +237,19 @@ my $nr = 0; - my @lookups; + my @sources; + + my $lookup_src_cache; + + my $only_database = $self->{only_database}; + my $only_input = $self->{only_input}; $self->{config}->iterate_inputs( sub { my ($input, $database) = @_; + return if ( $only_database && $database !~ m/$only_database/i ); + return if ( $only_input && $input->{name} !~ m/$only_input/i ); + $log->debug("database: $database input = ", dump($input)); foreach my $normalize (@{ $input->{normalize} }) { @@ -188,8 +268,9 @@ $self->{valid_inputs}->{$database}->{$input_name}++; - push @lookups, sub { - $self->_parse_lookups( $database, $input_name, $full, $s ); + push @sources, sub { + #warn "### $database $input_name, $full ###\n"; + $self->_parse_source( $database, $input_name, $full, $s ); }; $nr++; @@ -198,15 +279,15 @@ $log->debug("found $nr source files"); - # parse all lookups - $_->() foreach (@lookups); + # parse all sources + $_->() foreach (@sources); return $nr; } -=head2 _parse_lookups +=head2 _parse_source - $parser->_parse_lookups($database,$input,$path,$source); + $parser->_parse_source($database,$input,$path,$source); Called for each normalize source (rules) in each input by L @@ -214,7 +295,7 @@ =cut -sub _parse_lookups { +sub _parse_source { my $self = shift; my ($database, $input, $path, $source) = @_; @@ -232,6 +313,7 @@ my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source}); $Document->prune('PPI::Token::Whitespace'); + $Document->prune('PPI::Token::Comment'); #$Document->prune('PPI::Token::Operator'); # Find all the named subroutines @@ -250,6 +332,15 @@ my ($Document,$Element) = @_; $Element->isa('PPI::Token::Word') or return ''; + + if ( $Element->content =~ m{^(sub|if)$} ) { + # repair demage done by prune of whitespace + $Element->insert_after( PPI::Token::Whitespace->new(' ') ); + return ''; + } elsif ( $Element->content eq 'my' ) { + $Element->insert_before( PPI::Token::Whitespace->new(' ') ); + } + $Element->content eq 'lookup' or return ''; $log->debug("expansion: ", $Element->snext_sibling); @@ -296,13 +387,15 @@ $log->debug("key = $key"); - my $create = "save_into_lookup('$key', $e[7] $e[8] );\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] ); + my $create = qq{ + save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] ); + }; + + $log->debug("create: $create"); + # save code to create this lookup $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create; $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++; @@ -322,7 +415,7 @@ } $e[7]->remove; - $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) ); + $e[8]->insert_before( PPI::Token::Quote::Single->new( "'$key'" ) ); $e[8]->remove; @@ -333,7 +426,7 @@ $log->debug("create: ", dump($self->{_lookup_create}) ); $log->debug("normalize: $normalize_source"); - $self->{_normalize_source}->{$database}->{$input} = $normalize_source; + $self->{_normalize_source}->{$database}->{$input} .= $normalize_source; if ($self->{debug}) { my $Dumper = PPI::Dumper->new( $Document ); @@ -342,6 +435,19 @@ $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors}); + $Document->find( sub { + my ($Document,$Element) = @_; + + $Element->isa('PPI::Token::Word') or return ''; + if ($Element->content =~ m/^(marc|search)/) { + my $what = $1; + $log->debug("found $what rules in $database/$input"); + $self->{_have_rules}->{ $database }->{ $input }->{ $what }->{ $Element->content }++; + } else { + return ''; + } + }); + return 1; }