git.rot13.org Git - webpac2/blob - lib/WebPAC/Parser.pm

   1 package WebPAC::Parser;
   2
   3 use warnings;
   4 use strict;
   5
   6
   7 use PPI;
   8 use PPI::Dumper;
   9 use Data::Dump qw/dump/;
  10 use File::Slurp;
  11
  12 use base qw/WebPAC::Common/;
  13
  14 =head1 NAME
  15
  16 WebPAC::Parser - parse perl normalization configuration files (rules) and mungle it
  17
  18 =head1 VERSION
  19
  20 Version 0.08
  21
  22 =cut
  23
  24 our $VERSION = '0.08';
  25
  26 =head1 SYNOPSIS
  27
  28 This module will parse L<WebPAC::Normalize/lookup> directives and generate source
  29 to produce lookups and normalization. It will also parse other parts of
  30 source to produce some of DWIM (I<Do What I Mean>) magic
  31 (like producing MARC oputput using L<WebPAC::Output::MARC> if there are C<marc_*>
  32 rules in normalisation).
  33
  34 It's written using L<PPI>, pure-perl parser for perl and heavily influenced by
  35 reading about LISP. It might be a bit over-the board, but at least it removed
  36 separate configuration files for lookups.
  37
  38 This is experimental code, but it replaces all older formats which where,
  39 at one point in time, available in WebPAC.
  40
  41 FIXME
  42
  43 =head1 FUNCTIONS
  44
  45 =head2 new
  46
  47 Create new parser object.
  48
  49   my $parser = new WebPAC::Parser(
  50         config => new WebPAC::Config(),
  51         base_path => '/optional/path/to/conf',
  52         only_database => $only
  53   );
  54
  55 =cut
  56
  57 sub new {
  58         my $class = shift;
  59         my $self = {@_};
  60         bless($self, $class);
  61
  62         my $log = $self->_get_logger();
  63
  64         $log->logdie("config isn't WebPAC::Config") unless ($self->{config} && $self->{config}->isa('WebPAC::Config'));
  65
  66         $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));
  67
  68         $self->_read_sources;
  69
  70         $self ? return $self : return undef;
  71 }
  72
  73 =head2 valid_database
  74
  75   my $ok = $parse->valid_database('key');
  76
  77 =cut
  78
  79 sub valid_database {
  80         my $self = shift;
  81
  82         my $database = shift || return;
  83
  84         return defined($self->{valid_inputs}->{ _q($database) });
  85 }
  86
  87 =head2 valid_database_input
  88
  89   my $ok = $parse->valid_database('database_key','input_name');
  90
  91 =cut
  92
  93 sub valid_database_input {
  94         my $self = shift;
  95         my ($database,$input) = @_;
  96         $input = _input_name($input);
  97         return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
  98 }
  99
 100 =head2 depends
 101
 102 Return all databases and inputs on which specified one depends
 103
 104   $depends_on = $parser->depends('database','input');
 105
 106 =cut
 107
 108 sub depends {
 109         my $self = shift;
 110         my ($database,$input) = @_;
 111         $input = _input_name($input);
 112         $self->_get_logger->debug("depends($database,$input)");
 113         return unless (
 114                 defined( $self->{depends}->{ _q($database) } ) &&
 115                 defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
 116         );
 117         return $self->{depends}->{ _q($database) }->{ _q($input) };
 118 }
 119
 120 =head2 have_lookup_create
 121
 122   my @keys = $parser->have_lookup_create($database, $input);
 123
 124 =cut
 125
 126 sub have_lookup_create {
 127         my $self = shift;
 128         my ($database,$input) = @_;
 129         $input = _input_name($input);
 130         return unless (
 131                 defined( $self->{_lookup_create_key}->{ _q($database) } ) &&
 132                 defined( $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } )
 133         );
 134         return keys %{ $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } };
 135 }
 136
 137
 138 =head2 lookup_create_rules
 139
 140   my $source = $parser->lookup_create_rules($database, $input);
 141
 142 =cut
 143
 144 sub lookup_create_rules {
 145         my $self = shift;
 146         my ($database,$input) = @_;
 147         $input = _input_name($input);
 148         return unless (
 149                 defined( $self->{_lookup_create}->{ _q($database) } ) &&
 150                 defined( $self->{_lookup_create}->{ _q($database) }->{ _q($input) } )
 151         );
 152         return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
 153 }
 154
 155 =head2 normalize_rules
 156
 157   my $source = $parser->normalize_rules($database, $input);
 158
 159 =cut
 160
 161 sub normalize_rules {
 162         my $self = shift;
 163         my ($database,$input) = @_;
 164         $input = _input_name($input);
 165         return unless (
 166                 defined( $self->{_normalize_source}->{ _q($database) } ) &&
 167                 defined( $self->{_normalize_source}->{ _q($database) }->{ _q($input) } )
 168         );
 169         return $self->{_normalize_source}->{ _q($database) }->{ _q($input) };
 170 }
 171
 172
 173 =head2 have_rules
 174
 175   my $do_marc = $parser->have_rules('marc', $database, $input);
 176   my $do_index = $parser->have_rules('search', $database);
 177
 178 This function will return hash containing count of all found C<marc_*> or
 179 C<search> directives. Input name is optional.
 180
 181 =cut
 182
 183 sub have_rules {
 184         my $self = shift;
 185
 186         my $log = $self->_get_logger();
 187         my $type = shift @_ || $log->logconfess("need at least type");
 188         my $database = shift @_ || $log->logconfess("database is required");
 189         my $input = shift @_;
 190
 191         $input = _input_name($input);
 192
 193
 194         return unless defined( $self->{_have_rules}->{ _q($database) } );
 195
 196         my $database_rules = $self->{_have_rules}->{ _q($database ) };
 197
 198         if (defined($input)) {
 199
 200                 return unless (
 201                         defined( $database_rules->{ _q($input) } ) &&
 202                         defined( $database_rules->{ _q($input) }->{ $type } )
 203                 );
 204
 205                 return $database_rules->{ _q($input) }->{ $type };
 206         }
 207
 208         my $usage;
 209
 210         foreach my $i (keys %{ $database_rules }) {
 211                 next unless defined( $database_rules->{$i}->{$type} );
 212
 213                 foreach my $t (keys %{ $database_rules->{ $i }->{$type} }) {
 214                         $usage->{ $t } += $database_rules->{ $i }->{ $t };
 215                 }
 216         }
 217
 218         return $usage;
 219
 220 }
 221
 222
 223 =head1 PRIVATE
 224
 225 =head2 _read_sources
 226
 227   my $source_files = $parser->_read_sources;
 228
 229 Called by L</new>.
 230
 231 =cut
 232
 233 sub _read_sources {
 234         my $self = shift;
 235
 236         my $log = $self->_get_logger();
 237
 238         my $nr = 0;
 239
 240         my @sources;
 241
 242         my $lookup_src_cache;
 243
 244         my $only_database = $self->{only_database};
 245         my $only_input = $self->{only_input};
 246
 247         $self->{config}->iterate_inputs( sub {
 248                 my ($input, $database) = @_;
 249
 250                 return if ( $only_database && $database !~ m/$only_database/i );
 251                 return if ( $only_input && $input->{name} !~ m/$only_input/i );
 252
 253                 $log->debug("database: $database input = ", dump($input));
 254
 255                 foreach my $normalize (@{ $input->{normalize} }) {
 256
 257                         my $path = $normalize->{path};
 258                         return unless($path);
 259                         my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
 260
 261                         $log->logdie("normalization input $full doesn't exist") unless (-e $full);
 262
 263                         my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
 264
 265                         my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
 266
 267                         $log->debug("$database/$input_name: adding $path");
 268
 269                         $self->{valid_inputs}->{$database}->{$input_name}++;
 270
 271                         push @sources, sub {
 272                                 #warn "### $database $input_name, $full ###\n";
 273                                 $self->_parse_source( $database, $input_name, $full, $s );
 274                         };
 275
 276                         $nr++;
 277                 }
 278         } );
 279
 280         $log->debug("found $nr source files");
 281
 282         # parse all sources
 283         $_->() foreach (@sources);
 284
 285         return $nr;
 286 }
 287
 288 =head2 _parse_source
 289
 290   $parser->_parse_source($database,$input,$path,$source);
 291
 292 Called for each normalize source (rules) in each input by L</_read_sources>
 293
 294 It will report invalid databases and inputs in error log after parsing.
 295
 296 =cut
 297
 298 sub _parse_source {
 299         my $self = shift;
 300         my ($database, $input, $path, $source) = @_;
 301
 302         $input = _input_name($input);
 303
 304         my $log = $self->_get_logger();
 305
 306         $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
 307         $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
 308
 309         $log->logdie("no source found for database $database input $input path $path") unless ($source);
 310
 311         $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
 312
 313         my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});
 314
 315         $Document->prune('PPI::Token::Whitespace');
 316         $Document->prune('PPI::Token::Comment');
 317         #$Document->prune('PPI::Token::Operator');
 318
 319         # Find all the named subroutines
 320
 321         $self->{_lookup_errors} = ();
 322
 323         sub _lookup_error {
 324                 my $self = shift;
 325                 my $msg = shift;
 326                 $self->_get_logger->logconfess("error without message?") unless ($msg);
 327                 push @{ $self->{_lookup_errors} }, $msg;
 328                 return '';
 329         }
 330
 331         $Document->find( sub {
 332                         my ($Document,$Element) = @_;
 333
 334                         $Element->isa('PPI::Token::Word') or return '';
 335
 336                         if ( $Element->content =~ m{^(sub|if)$} ) {
 337                                 # repair demage done by prune of whitespace
 338                                 $Element->insert_after( PPI::Token::Whitespace->new(' ') );
 339                                 return '';
 340                         } elsif ( $Element->content eq 'my' ) {
 341                                 $Element->insert_before( PPI::Token::Whitespace->new(' ') );
 342                         }
 343
 344                         $Element->content eq 'lookup' or return '';
 345
 346                         $log->debug("expansion: ", $Element->snext_sibling);
 347
 348                         my $args = $Element->snext_sibling;
 349
 350                         my @e = $args->child(0)->elements;
 351                         $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
 352
 353                         if ($log->is_debug) {
 354                                 my $report = "found " . scalar @e . " elements:\n";
 355
 356                                 foreach my $i ( 0 .. $#e ) {
 357                                         $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
 358                                 }
 359
 360                                 $log->debug($report);
 361                         }
 362
 363                         my $key_element = $e[8]->clone;
 364
 365                         $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
 366
 367                         $log->debug("key part: ", $key_element);
 368
 369                         my @key;
 370
 371                         $key_element->find( sub {
 372                                 my $e = $_[1] || die "no element?";
 373                                 $e->isa('PPI::Token::Word') or return '';
 374                                 $e->content eq 'rec' or return '';
 375
 376                                 my $kf = $e->snext_sibling;
 377
 378                                 $log->debug("key fragment = $kf");
 379
 380                                 push @key, eval $kf;
 381                                 $log->logdie("can't eval { $kf }: $@") if ($@);
 382
 383                                 return 1;
 384                         });
 385
 386                         my $key = join('-', @key ) || $log->logdie("no key found!");
 387
 388                         $log->debug("key = $key");
 389
 390                         return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
 391                         return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
 392
 393                         my $create = qq{
 394                                 save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
 395                         };
 396
 397                         $log->debug("create: $create");
 398
 399                         # save code to create this lookup
 400                         $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create;
 401                         $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
 402
 403
 404                         if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
 405                                 $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
 406                         }
 407
 408                         # save this dependency
 409                         $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
 410
 411                         if ($#e < 10) {
 412                                 $e[8]->insert_after( $e[8]->clone );
 413                                 $e[8]->insert_after( $e[7]->clone );
 414                                 $e[8]->insert_after( $e[6]->clone );
 415                         }
 416
 417                         $e[7]->remove;
 418                         $e[8]->insert_before( PPI::Token::Quote::Single->new( "'$key'" ) );
 419                         $e[8]->remove;
 420
 421
 422                         $log->debug(">>> ", $Element->snext_sibling);
 423         });
 424
 425         my $normalize_source = $Document->serialize;
 426         $log->debug("create: ", dump($self->{_lookup_create}) );
 427         $log->debug("normalize: $normalize_source");
 428
 429         $self->{_normalize_source}->{$database}->{$input} .= $normalize_source;
 430
 431         if ($self->{debug}) {
 432                 my $Dumper = PPI::Dumper->new( $Document );
 433                 $Dumper->print;
 434         }
 435
 436         $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
 437
 438         $Document->find( sub {
 439                         my ($Document,$Element) = @_;
 440
 441                         $Element->isa('PPI::Token::Word') or return '';
 442                         if ($Element->content =~ m/^(marc|search)/) {
 443                                 my $what = $1;
 444                                 $log->debug("found $what rules in $database/$input");
 445                                 $self->{_have_rules}->{ $database }->{ $input }->{ $what }->{ $Element->content }++;
 446                         } else {
 447                                 return '';
 448                         }
 449         });
 450
 451         return 1;
 452 }
 453
 454
 455 =head2 _q
 456
 457 Strip single or double quotes around value
 458
 459   _q(qq/'foo'/) -> foo
 460
 461 =cut
 462
 463 sub _q {
 464         my $v = shift || return;
 465         $v =~ s/^['"]*//g;
 466         $v =~ s/['"]*$//g;
 467         return $v;
 468 }
 469
 470 =head2 _input_name
 471
 472 Return C<name> value if HASH or arg if scalar
 473
 474   _input_name($input)
 475
 476 =cut
 477
 478 sub _input_name {
 479         my $input = shift || return;
 480         if (ref($input) eq 'HASH') {
 481                 die "can't find 'name' value in ", dump($input) unless defined($input->{name});
 482                 return $input->{name};
 483         } else {
 484                 return $input;
 485         }
 486 }
 487
 488
 489 =head1 AUTHOR
 490
 491 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 492
 493 =head1 COPYRIGHT & LICENSE
 494
 495 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 496
 497 This program is free software; you can redistribute it and/or modify it
 498 under the same terms as Perl itself.
 499
 500 =cut
 501
 502 1; # End of WebPAC::Parser