perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From do...@apache.org
Subject cvs commit: modperl-2.0/Apache-Test/lib/Apache TestConfigPerl.pm
Date Mon, 02 Apr 2001 08:57:34 GMT
dougm       01/04/02 01:57:34

  Added:       Apache-Test/lib/Apache TestConfigPerl.pm
  Log:
  test config stuff specific to modperl
  
  Revision  Changes    Path
  1.1                  modperl-2.0/Apache-Test/lib/Apache/TestConfigPerl.pm
  
  Index: TestConfigPerl.pm
  ===================================================================
  package Apache::TestConfig; #not TestConfigPerl on purpose
  
  #things specific to mod_perl
  
  use strict;
  use warnings FATAL => 'all';
  use File::Spec::Functions qw(catfile splitdir abs2rel);
  use File::Find qw(finddepth);
  
  my %libmodperl  = (1 => 'libperl.so', 2 => 'libmodperl.so');
  
  sub configure_libmodperl {
      my $self = shift;
  
      my $server = $self->{server};
      my $libname = $server->version_of(\%libmodperl);
  
      if ($server->{rev} >= 2) {
          if (my $build_config = $self->build_config()) {
              $libname = $build_config->{MODPERL_LIB_SHARED}
          }
      }
  
      my $vars = $self->{vars};
  
      $vars->{libmodperl} ||= $self->find_apache_module($libname);
  
      my $cfg;
  
      if (-e $vars->{libmodperl}) {
          $cfg = {LoadModule => qq(perl_module "$vars->{libmodperl}")};
      }
      else {
          my $msg = "unable to locate $libname\n";
          $cfg = "#$msg";
          $self->trace($msg);
      }
      $self->preamble(IfModule => '!mod_perl.c', $cfg);
  }
  
  sub configure_inc {
      my $self = shift;
  
      my $top = $self->{vars}->{top_dir};
  
      my $inc = $self->{inc};
      my @trys = (catfile($top, 'lib'),
                  catfile($top, qw(blib lib)),
                  catfile($top, qw(blib arch)));
  
      for (@trys) {
          push @$inc, $_ if -d $_;
      }
  }
  
  sub write_pm_test {
      my($self, $pm, $base, $sub) = @_;
  
      my $dir = catfile $self->{vars}->{t_dir}, $base;
      my $t = catfile $dir, "$sub.t";
      return if -e $t;
  
      $self->gendir($dir);
      my $fh = $self->genfile($t);
  
      print $fh <<EOF;
  use Apache::TestConfig ();
  print Apache::TestConfig->thaw->http_raw_get("/$pm");
  EOF
  
      close $fh or die "close $t: $!";
  }
  
  
  my %startup_pl = (1 => 'PerlRequire', 2 => 'PerlSwitches');
  
  sub startup_pl_code {
      return <<'EOF';
  BEGIN {
      for my $file (qw(modperl_inc.pl modperl_extra.pl)) {
          eval { require "conf/$file" };
      }
  }
  
  1;
  EOF
  }
  
  sub configure_startup_pl {
      my $self = shift;
  
      #for 2.0 we could just use PerlSwitches -Mlib=...
      #but this will work for both 2.0 and 1.xx
      if (my $inc = $self->{inc}) {
          my $include_pl = catfile $self->{vars}->{t_conf}, 'modperl_inc.pl';
          my $fh = $self->genfile($include_pl);
          for (@$inc) {
              print $fh "use lib '$_';\n";
          }
          print $fh "1;\n";
      }
  
      if ($self->server->{rev} >= 2) {
          $self->postamble(PerlSwitches => "-Mlib=$self->{vars}->{serverroot}");
      }
  
      my $startup_pl = catfile $self->{vars}->{t_conf}, 'modperl_startup.pl';
  
      unless (-e $startup_pl) {
          my $fh = $self->genfile($startup_pl);
          print $fh $self->startup_pl_code;
          close $fh;
      }
  
      my $directive = $self->server->version_of(\%startup_pl);
      $self->postamble($directive => $startup_pl);
  }
  
  my %sethandler_modperl = (1 => 'perl-script', 2 => 'modperl');
  
  my %add_hook_config = (
      Response => sub { my($self, $module, $args) = @_;
                        push @$args,
                          SetHandler =>
                            $self->server->version_of(\%sethandler_modperl) },
      ProcessConnection => sub { my($self, $module, $args) = @_;
                                 my $port = $self->new_vhost($module);
                                 $self->postamble(Listen => $port); },
  );
  
  my %container_config = (
      ProcessConnection => \&vhost_container,
  );
  
  sub location_container {
      my($self, $module) = @_;
      Location => "/$module";
  }
  
  sub vhost_container {
      my($self, $module) = @_;
      my $port = $self->{vhosts}->{$module}->{port};
      VirtualHost => "_default_:$port";
  }
  
  sub new_vhost {
      my($self, $module) = @_;
  
      my $port       = $self->server->select_port;
      my $servername = $self->{vars}->{servername};
      my $vhost      = $self->{vhosts}->{$module} = {};
  
      $vhost->{port}       = $port;
      $vhost->{servername} = $servername;
      $vhost->{name}       = join ':', $servername, $port;
      $vhost->{hostport}   = $self->hostport($vhost);
  
      $port;
  }
  
  #test .pm's can have configuration after the __DATA__ token
  sub add_module_config {
      my($self, $module, $args) = @_;
      open(my $fh, $module) or return;
  
      while (<$fh>) {
          last if /^__DATA__/;
      }
  
      while (<$fh>) {
          next unless /\S+/;
          push @$args, split /\s+/, $_, 2;
      }
  }
  
  #the idea for each group:
  # Response: there will be many of these, mostly modules to test the API
  #           that plan tests => ... and output with ok()
  #           the naming allows grouping, making it easier to run an
  #           individual set of tests, e.g. t/TEST t/apr
  #           the PerlResponseHandler and SetHandler modperl is auto-configured
  # Hooks:    for testing the simpler Perl*Handlers
  #           auto-generates the Perl*Handler config
  # Protocol: protocol modules need their own port/vhost to listen on
  
  #@INC is auto-modified so each test .pm can be found
  #modules can add their own configuration using __DATA__
  
  my %hooks = map { $_, ucfirst $_ } qw(authen);
  $hooks{Protocol} = 'ProcessConnection';
  $hooks{Filter}   = 'OutputFilter';
  
  sub configure_pm_tests {
      my $self = shift;
  
      for my $subdir (qw(Response Protocol Hooks Filter)) {
          my $dir = catfile $self->{vars}->{t_dir}, lc $subdir;
          next unless -d $dir;
  
          push @{ $self->{inc} }, $dir;
  
          finddepth(sub {
              return unless /\.pm$/;
              my @args;
  
              my $module = catfile $File::Find::dir, $_;
              $self->add_module_config($module, \@args);
              $module = abs2rel $module, $dir;
              $module =~ s,\.pm$,,;
              $module = join '::', splitdir $module;
  
              my($base, $sub) =
                map { s/^test//i; $_ } split '::', $module;
  
              my $hook = $hooks{$sub} || $hooks{$subdir} || $subdir;
              my $handler = join $hook, qw(Perl Handler);
  
              if ($self->server->{rev} < 2 and lc($hook) eq 'response') {
                  $handler =~ s/response//i; #s/PerlResponseHandler/PerlHandler/
              }
  
              $self->trace("configuring $module");
  
              if (my $cv = $add_hook_config{$hook}) {
                  $self->$cv($module, \@args);
              }
  
              my $container = $container_config{$hook} || \&location_container;
              $self->postamble($self->$container($module),
                               { $handler => $module, @args });
  
              $self->write_pm_test($module, lc $base, lc $sub);
          }, $dir);
      }
  }
  
  1;
  
  
  

Mime
View raw message