--- trunk/lib/WebPAC/Parser.pm 2006/09/25 13:46:36 705 +++ trunk/lib/WebPAC/Parser.pm 2006/10/08 20:28:17 755 @@ -9,24 +9,27 @@ use Data::Dump qw/dump/; use File::Slurp; -use base qw/WebPAC::Common WebPAC::Normalize/; +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.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 @@ -113,6 +116,24 @@ return $self->{depends}->{ _q($database) }->{ _q($input) }; } +=head2 have_lookup_create + + my @keys = $parser->have_lookup_create($database, $input); + +=cut + +sub have_lookup_create { + my $self = shift; + my ($database,$input) = @_; + $input = _input_name($input); + return unless ( + defined( $self->{_lookup_create_key}->{ _q($database) } ) && + defined( $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } ) + ); + return keys %{ $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } }; +} + + =head2 lookup_create_rules my $source = $parser->lookup_create_rules($database, $input); @@ -130,6 +151,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 @@ -147,7 +236,7 @@ my $nr = 0; - my @lookups; + my @sources; $self->{config}->iterate_inputs( sub { my ($input, $database) = @_; @@ -170,8 +259,8 @@ $self->{valid_inputs}->{$database}->{$input_name}++; - push @lookups, sub { - $self->_parse_lookups( $database, $input_name, $full, $s ); + push @sources, sub { + $self->_parse_source( $database, $input_name, $full, $s ); }; $nr++; @@ -180,23 +269,23 @@ $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 +Called for each normalize source (rules) in each input by L 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) = @_; @@ -214,6 +303,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 @@ -278,21 +368,18 @@ $log->debug("key = $key"); - my $create = ' - $coderef = ' . $e[7] . $e[8] . '; - foreach my $v ($coderef->()) { - next unless (defined($v) && $v ne \'\'); - push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn; - } - '; - - $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]) }->{ _q($key) } .= "# lookup for $e[3]/$e[5]/$key\n\n$create"; + $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create; + $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++; if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) { @@ -320,7 +407,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 ); @@ -329,6 +416,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; }