cvs commit: modperl-2.0/Apache-Test/lib/Apache TestConfigParse.pm

[dougm]

dougm       01/04/02 01:57:07

  Added:       Apache-Test/lib/Apache TestConfigParse.pm
  Log:
  methods t inherit values from exist httpd.conf and httpd -v,-V,-l
  
  Revision  Changes    Path
  1.1                  modperl-2.0/Apache-Test/lib/Apache/TestConfigParse.pm
  
  Index: TestConfigParse.pm
  ===================================================================
  package Apache::TestConfig; #not TestConfigParse on purpose
  
  #dont really want/need a full-blown parser
  #but do want something somewhat generic
  
  use strict;
  use warnings FATAL => 'all';
  use File::Spec::Functions qw(rel2abs splitdir);
  use File::Basename qw(basename);
  
  sub strip_quotes {
      local $_ = shift || $_;
      s/^\"//; s/\"$//; $_;
  }
  
  my %wanted_config = (
      TAKE1 => {map { $_, 1 } qw(ServerRoot ServerAdmin TypesConfig)},
      TAKE2 => {map { $_, 1 } qw(LoadModule)},
  );
  
  my %spec_init = (
      TAKE1 => sub { shift->{+shift} = "" },
      TAKE2 => sub { shift->{+shift} = [] },
  );
  
  my %spec_apply = (
      TypesConfig => \&inherit_server_file,
      ServerRoot  => sub {}, #dont override $self->{vars}->{serverroot}
      LoadModule  => \&inherit_load_module,
  );
  
  #where to add config, default is preamble
  my %spec_postamble = map { $_, 'postamble' } qw(TypesConfig);
  
  sub spec_add_config {
      my($self, $directive, $val) = @_;
  
      my $where = $spec_postamble{$directive} || 'preamble';
      $self->$where($directive => $val);
  }
  
  #resolve relative files like Apache->server_root_relative
  sub server_file {
      my($self, $file, $base) = @_;
  
      $base ||= $self->{inherit_config}->{ServerRoot};
      my $f = rel2abs $file, $base;
  
      return qq("$f");
  }
  
  sub inherit_server_file {
      my($self, $c, $directive) = @_;
  
      $self->spec_add_config($directive,
                             $self->server_file($c->{$directive}));
  }
  
  #inherit LoadModule
  sub inherit_load_module {
      my($self, $c, $directive) = @_;
  
      for my $args (@{ $c->{$directive} }) {
          my $modname = $args->[0];
          my $file = $self->server_file($args->[1]);
  
          my $name = basename $args->[1];
          $name =~ s/\.so$/.c/;  #mod_info.so => mod_info.c
          $name =~ s/^lib/mod_/; #libphp4.so => mod_php4.c
          $self->trace("LoadModule $modname $name");
          $self->{modules}->{$name} = 1;
  
          $self->preamble($directive => "$modname $file");
      }
  }
  
  sub parse_take1 {
      my($self, $c, $directive) = @_;
      $c->{$directive} = strip_quotes;
  }
  
  sub parse_take2 {
      my($self, $c, $directive) = @_;
      push @{ $c->{$directive} }, [map { strip_quotes } split];
  }
  
  sub apply_take1 {
      my($self, $c, $directive) = @_;
  
      if (exists $self->{vars}->{lc $directive}) {
          #override replacement @Variables@
          $self->{vars}->{lc $directive} = $c->{$directive};
      }
      else {
          $self->spec_add_config($directive, qq("$c->{$directive}"));
      }
  }
  
  sub apply_take2 {
      my($self, $c, $directive) = @_;
  
      for my $args (@{ $c->{$directive} }) {
          $self->spec_add_config($directive => [map { qq("$_") } @$args]);
      }
  }
  
  sub inherit_config {
      my $self = shift;
  
      $self->get_httpd_static_modules;
      $self->get_httpd_defines;
  
      my $file = $self->{vars}->{httpd_conf};
  
      unless ($file) {
          if (my $base = $self->{httpd_basedir}) {
              my $default_conf = $self->{httpd_defines}->{SERVER_CONFIG_FILE};
              $default_conf ||= catfile qw(conf httpd.conf);
              $file = catfile $base, $default_conf;
          }
      }
  
      return unless $file;
  
      $self->trace("inheriting config file: $file");
  
      open(my $fh, $file) or return;
  
      my $c = $self->{inherit_config};
  
      #initialize array refs and such
      while (my($spec, $wanted) = each %wanted_config) {
          for my $directive (keys %$wanted) {
              $spec_init{$spec}->($c, $directive);
          }
      }
  
      while (<$fh>) {
          s/^\s*//; s/\s*$//; s/^\#.*//;
          next if /^$/;
          (my $directive, $_) = split /\s+/, $_, 2;
  
          #parse what we want
          while (my($spec, $wanted) = each %wanted_config) {
              next unless $wanted->{$directive};
              my $method = "parse_\L$spec";
              $self->$method($c, $directive);
          }
      }
  
      #apply what we parsed
      while (my($spec, $wanted) = each %wanted_config) {
          for my $directive (keys %$wanted) {
              next unless $c->{$directive};
              my $cv = $spec_apply{$directive} ||
                       $self->can("apply_\L$directive") ||
                       $self->can("apply_\L$spec");
              $cv->($self, $c, $directive);
          }
      }
  
      close $fh;
  }
  
  sub get_httpd_static_modules {
      my $self = shift;
  
      my $httpd = $self->{vars}->{httpd};
      return unless $httpd;
  
      my $cmd = "$httpd -l";
      open my $list, '-|', $cmd or die "$cmd failed: $!";
  
      while (<$list>) {
          s/\s+$//;
          next unless /\.c$/;
          chomp;
          s/^\s+//;
          $self->{modules}->{$_} = 1;
      }
  
      close $list;
  }
  
  sub get_httpd_defines {
      my $self = shift;
  
      my $httpd = $self->{vars}->{httpd};
      return unless $httpd;
  
      my $cmd = "$httpd -V";
      open my $proc, '-|', $cmd or die "$cmd failed: $!";
  
      while (<$proc>) {
          next unless s/^\s*-D\s*//;
          s/\s+$//;
          chomp;
          my($key, $val) = split '=', $_, 2;
          $self->{httpd_defines}->{$key} = $val ? strip_quotes($val) : 1;
      }
  
      close $proc;
  }
  
  sub httpd_version {
      my $self = shift;
  
      my $httpd = $self->{vars}->{httpd};
      return unless $httpd;
  
      my $version;
      my $cmd = "$httpd -v";
      open my $v, '-|', $cmd or die "$cmd failed: $!";
  
      while (<$v>) {
          next unless s/^Server\s+version:\s*//i;
          chomp;
          $version = (split)[0];
          last;
      }
  
      close $v;
  
      return $version;
  }
  
  1;