home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / TestHarness.pm < prev    next >
Encoding:
Perl POD Document  |  2003-09-11  |  3.4 KB  |  164 lines
  1. package Apache::TestHarness;
  2.  
  3. use strict;
  4. use warnings FATAL => 'all';
  5.  
  6. use Test::Harness ();
  7. use Apache::TestSort ();
  8. use Apache::TestTrace;
  9. use File::Spec::Functions qw(catfile);
  10. use File::Find qw(finddepth);
  11. use File::Basename qw(dirname);
  12.  
  13. sub chdir_t {
  14.     chdir 't' if -d 't';
  15. #Apache::TestConfig->new takes care of @INC
  16. #    inc_fixup();
  17. }
  18.  
  19. sub inc_fixup {
  20.     # use blib
  21.     unshift @INC, map "blib/$_", qw(lib arch);
  22.  
  23.     # fix all relative library locations
  24.     for (@INC) {
  25.         $_ = "../$_" unless m,^(/)|([a-f]:),i;
  26.     }
  27. }
  28.  
  29. #skip tests listed in t/SKIP
  30. sub skip {
  31.     my($self, $file) = @_;
  32.     $file ||= 'SKIP';
  33.  
  34.     return unless -e $file;
  35.  
  36.     my $fh = Symbol::gensym();
  37.     open $fh, $file or die "open $file: $!";
  38.     my @skip;
  39.     local $_;
  40.  
  41.     while (<$fh>) {
  42.         chomp;
  43.         s/^\s+//; s/\s+$//; s/^\#.*//;
  44.         next unless $_;
  45.         s/\*/.*/g;
  46.         push @skip, $_;
  47.     }
  48.  
  49.     close $fh;
  50.     return join '|', @skip;
  51. }
  52.  
  53. #test if all.t would skip tests or not
  54. sub run_t {
  55.     my($self, $file) = @_;
  56.     my $ran = 0;
  57.     my $cmd = "$^X -Mlib=../Apache-Test/lib $file";
  58.  
  59.     my $h = Symbol::gensym();
  60.     open $h, "$cmd|" or die "open $cmd: $!";
  61.  
  62.     local $_;
  63.     while (<$h>) {
  64.         if (/^1\.\.(\d)/) {
  65.             $ran = $1;
  66.             last;
  67.         }
  68.     }
  69.  
  70.     close $h;
  71.  
  72.     $ran;
  73. }
  74.  
  75. #if a directory has an all.t test
  76. #skip all tests in that directory if all.t prints "1..0\n"
  77. sub prune {
  78.     my($self, @tests) = @_;
  79.     my(@new_tests, %skip_dirs);
  80.     local $_;
  81.  
  82.     for (@tests) {
  83.         my $dir = dirname $_;
  84.         if (m:\Wall\.t$:) {
  85.             unless ($self->run_t($_)) {
  86.                 $skip_dirs{$dir} = 1;
  87.                 @new_tests = grep { not $skip_dirs{dirname $_} } @new_tests;
  88.                 push @new_tests, $_;
  89.             }
  90.         }
  91.         elsif (!$skip_dirs{$dir}) {
  92.             push @new_tests, $_;
  93.         }
  94.     }
  95.  
  96.     @new_tests;
  97. }
  98.  
  99. sub get_tests {
  100.     my $self = shift;
  101.     my $args = shift;
  102.     my @tests = ();
  103.  
  104.     chdir_t();
  105.  
  106.     my $ts = $args->{tests} || [];
  107.  
  108.     if (@$ts) {
  109.     for (@$ts) {
  110.         if (-d $_) {
  111.         push(@tests, sort <$_/*.t>);
  112.         }
  113.         else {
  114.         $_ .= ".t" unless /\.t$/;
  115.         push(@tests, $_);
  116.         }
  117.     }
  118.     }
  119.     else {
  120.         if ($args->{tdirs}) {
  121.             push @tests, map { sort <$_/*.t> } @{ $args->{tdirs} };
  122.         }
  123.         else {
  124.             finddepth(sub {
  125.                           return unless /\.t$/;
  126.                           my $t = catfile $File::Find::dir, $_;
  127.                           my $dotslash = catfile '.', "";
  128.                           $t =~ s:^\Q$dotslash::;
  129.                           push @tests, $t
  130.                       }, '.');
  131.             @tests = sort @tests;
  132.         }
  133.     }
  134.  
  135.     @tests = $self->prune(@tests);
  136.  
  137.     if (my $skip = $self->skip) {
  138.         @tests = grep { not /(?:$skip)/ } @tests;
  139.     }
  140.  
  141.     Apache::TestSort->run(\@tests, $args);
  142.  
  143.     #when running 't/TEST t/dir' shell tab completion adds a /
  144.     #dir//foo output is annoying, fix that.
  145.     s:/+:/:g for @tests;
  146.  
  147.     return @tests;
  148. }
  149.  
  150. sub run {
  151.     my $self = shift;
  152.     my $args = shift || {};
  153.  
  154.     $Test::Harness::verbose ||= $args->{verbose};
  155.  
  156.     if (my(@subtests) = @{ $args->{subtests} || [] }) {
  157.         $ENV{HTTPD_TEST_SUBTESTS} = "@subtests";
  158.     }
  159.  
  160.     Test::Harness::runtests($self->get_tests($args, @_));
  161. }
  162.  
  163. 1;
  164.