fix foreach my combination

[webpac2] / lib / WebPAC / Parser.pm

diff --git a/lib/WebPAC/Parser.pm b/lib/WebPAC/Parser.pm
index b7f8870..5d2e72f 100644 (file)
--- a/lib/WebPAC/Parser.pm
+++ b/lib/WebPAC/Parser.pm
@@ -13,20 +13,23 @@ use base qw/WebPAC::Common/;
 
 =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.06
+Version 0.08
 
 =cut
 
-our $VERSION = '0.06';
+our $VERSION = '0.08';
 
 =head1 SYNOPSIS
 
 This module will parse L<WebPAC::Normalize/lookup> 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<Do What I Mean>) magic
+(like producing MARC oputput using L<WebPAC::Output::MARC> if there are C<marc_*>
+rules in normalisation).
 
 It's written using L<PPI>, 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 @@ Create new parser object.
   my $parser = new WebPAC::Parser(
        config => new WebPAC::Config(),
        base_path => '/optional/path/to/conf',
+       only_database => $only
   );
 
 =cut
@@ -165,6 +169,57 @@ sub normalize_rules {
        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<marc_*> or
+C<search> 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
@@ -182,11 +237,19 @@ sub _read_sources {
 
        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} }) {
@@ -205,8 +268,9 @@ sub _read_sources {
 
                        $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++;
@@ -215,15 +279,15 @@ sub _read_sources {
 
        $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</_read_sources>
 
@@ -231,7 +295,7 @@ It will report invalid databases and inputs in error log after parsing.
 
 =cut
 
-sub _parse_lookups {
+sub _parse_source {
        my $self = shift;
        my ($database, $input, $path, $source) = @_;
 
@@ -268,6 +332,15 @@ sub _parse_lookups {
                        my ($Document,$Element) = @_;
 
                        $Element->isa('PPI::Token::Word') or return '';
+
+                       if ( $Element->content eq 'sub' ) {
+                               # 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);
@@ -342,7 +415,7 @@ sub _parse_lookups {
                        }
 
                        $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;
 
 
@@ -362,6 +435,19 @@ sub _parse_lookups {
 
        $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;
 }