view release on metacpan or  search on metacpan

lib/ApacheLog/Parser/Report.pm  view on Meta::CPAN

  my $self = shift;

  my @conf = @{$self->{conf}};

  my $s = $self->{store} = {};
  my @preface;
  my @codes;
  foreach my $item (@conf) {
    my $name = $item->{name};
    $s->{$name} = {};
    unless($item->{where}) {
      #warn "$name is a stub\n";
      next;
    }
    #warn "gen code for $name ($item->{title})\n";
    my ($code, $pre) = $self->_code_for($item);
    push(@codes, $code);
    push(@preface, $pre) if($pre);
    if(0) {
      warn "#"x72, "\n";
      warn "for $name\n$code", ($pre ? "\n\n$pre\n" : '');
    }
  }
  $ENV{DBG} and warn join("\n", @preface), join("\n", @codes);
  $self->_compile(join("\n", @preface), join("\n", @codes));
} # end subroutine get_func definition
########################################################################
sub _compile {
  my $s = $_[0]->{store};
  my $func = eval("$_[1];
  use ApacheLog::Parser qw(:fields);
  sub {
    my \$v = shift;
    my \$p;
    my \@ans;
    $_[2]
    no ApacheLog::Parser;
  }
  ");
  $@ and croak("cannot compile $_[1]/\n$_[2]\n  -- $@");
  return($func);
}
sub _code_for {
  my $self = shift;
  my ($item) = @_;

  my $name = $item->{name};
  $ENV{DBG} and warn "building rules for $name\n";
  # need to work-out the pre-reqs
  my $preface;
  my $callcode;
  if(my $code = $item->{code}) {
    $callcode = '$_' . $name . '_code';
    $preface = join("\n",
      'my ' . $callcode . ' = sub {',
      $code,
      '};'
    );
  }
  # then the total number of captures?
  # bind everything to ^$ ?
  # switch some to eq?
  my $has_matches = sub {
    my ($string) = @_;
    defined($string) or die "no string";
    return($string =~ m/(?<!\\)\((?!\?)/ ? 1 : 0);
  };
  my $before;
  my @code;
  my @conds;
  my $some_matches = 0;
  foreach my $cond (@{$item->{where}}) {
    my @subs;
    foreach my $thing (sort(keys(%$cond))) {
      my $re = $cond->{$thing};
      if($thing eq 'params') {
        $before =
          '$p ||= {map({my @g = split(/=/, $_, 2); ($#g?@g:())}' .
          ' split(/&/, $v->[params]))};';
        foreach my $p (split(/ & /, $re)) {
          my ($name, $want) = split(/=/, $p, 2);
          push(@subs, ["(\$p->{$name}||'')", $want]);
        }
      }
      else {
        # the \$v->[$thing] =~ m#$re# bit
        push(@subs, ["\$v->[$thing]", $re]);
      }
    }
    # and-together all of the subconditions
    my $had_match = 0;
    my @pref = ('(@ans = ', 'push(@ans, ');
    my @built;
    foreach my $subc (@subs) {
      my $start;
      if($has_matches->($subc->[1])) {
        $start = $pref[$had_match];
        $some_matches = 1;
        $had_match = 1;
      }
      else {
        $start = '(';
      }
      push(@built, $start . $subc->[0] . ' =~ m#^' . $subc->[1] . '$#)');
    }
    # single subcondition
    push(@conds, $#built ? join(' and ',map({"($_)"} @built)) : @built);
  }
  #warn "$name ", $some_matches ? 'yes' : 'no', "\n\n";
  # or-together all of the where's
  my $code = ($before ? "$before\n" : '') .
    'if(' . (
    $#conds ?
      "\n  " . join(" or\n", map({"  ($_)"} @conds)) . "\n" :
      $conds[0]
    ) .
    ") {\n  " .
    # must clear-out the answer slot if there were never any match vars
    ($callcode ?
      ($some_matches ? '' : '@ans = ();') . $callcode . '->(@ans)' :
      "(\$s->{$name}{" . ($some_matches ? '$ans[0]' : q('') ) .