home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / TestHarness.pm < prev    next >
Encoding:
Perl POD Document  |  2004-08-09  |  4.4 KB  |  196 lines
  1. # Copyright 2001-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package Apache::TestHarness;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19.  
  20. use Test::Harness ();
  21. use Apache::Test ();
  22. use Apache::TestSort ();
  23. use Apache::TestTrace;
  24. use File::Spec::Functions qw(catfile catdir);
  25. use File::Find qw(finddepth);
  26. use File::Basename qw(dirname);
  27.  
  28. sub inc_fixup {
  29.     # use blib
  30.     unshift @INC, map "blib/$_", qw(lib arch);
  31.  
  32.     # fix all relative library locations
  33.     for (@INC) {
  34.         $_ = "../$_" unless m,^(/)|([a-f]:),i;
  35.     }
  36. }
  37.  
  38. #skip tests listed in t/SKIP
  39. sub skip {
  40.     my($self, $file) = @_;
  41.     $file ||= catfile Apache::Test::vars('serverroot'), 'SKIP';
  42.  
  43.     return unless -e $file;
  44.  
  45.     my $fh = Symbol::gensym();
  46.     open $fh, $file or die "open $file: $!";
  47.     my @skip;
  48.     local $_;
  49.  
  50.     while (<$fh>) {
  51.         chomp;
  52.         s/^\s+//; s/\s+$//; s/^\#.*//;
  53.         next unless $_;
  54.         s/\*/.*/g;
  55.         push @skip, $_;
  56.     }
  57.  
  58.     close $fh;
  59.     return join '|', @skip;
  60. }
  61.  
  62. #test if all.t would skip tests or not
  63. sub run_t {
  64.     my($self, $file) = @_;
  65.     my $ran = 0;
  66.  
  67.     my $source_lib = '';
  68.  
  69.     if (Apache::TestConfig::IS_APACHE_TEST_BUILD) {
  70.         # so we can find Apache/Test.pm from both the perl-framework/
  71.         # and Apache-Test/
  72.  
  73.         my $top_dir = Apache::Test::vars('top_dir');
  74.  
  75.         foreach my $lib (catfile($top_dir, qw(Apache-Test lib)),
  76.                          catfile($top_dir, 'lib')) {
  77.  
  78.             if (-d $lib) {
  79.  
  80.                 info "adding source lib $lib to \@INC";
  81.  
  82.                 $source_lib = qq[-Mlib="$lib"];
  83.  
  84.                 last;
  85.             }
  86.         }
  87.     }
  88.     
  89.     my $cmd = qq[$^X $source_lib $file];
  90.  
  91.     my $h = Symbol::gensym();
  92.     open $h, "$cmd|" or die "open $cmd: $!";
  93.  
  94.     local $_;
  95.     while (<$h>) {
  96.         if (/^1\.\.(\d)/) {
  97.             $ran = $1;
  98.             last;
  99.         }
  100.     }
  101.  
  102.     close $h;
  103.  
  104.     $ran;
  105. }
  106.  
  107. #if a directory has an all.t test
  108. #skip all tests in that directory if all.t prints "1..0\n"
  109. sub prune {
  110.     my($self, @tests) = @_;
  111.     my(@new_tests, %skip_dirs);
  112.     local $_;
  113.  
  114.     for (@tests) {
  115.         my $dir = dirname $_;
  116.         if (m:\Wall\.t$:) {
  117.             unless ($self->run_t($_)) {
  118.                 $skip_dirs{$dir} = 1;
  119.                 @new_tests = grep { not $skip_dirs{dirname $_} } @new_tests;
  120.                 push @new_tests, $_;
  121.             }
  122.         }
  123.         elsif (!$skip_dirs{$dir}) {
  124.             push @new_tests, $_;
  125.         }
  126.     }
  127.  
  128.     @new_tests;
  129. }
  130.  
  131. sub get_tests {
  132.     my $self = shift;
  133.     my $args = shift;
  134.     my @tests = ();
  135.  
  136.     my $base = -d 't' ? catdir('t', '.') : '.';
  137.  
  138.     my $ts = $args->{tests} || [];
  139.  
  140.     if (@$ts) {
  141.     for (@$ts) {
  142.         if (-d $_) {
  143.         push(@tests, sort <$base/$_/*.t>);
  144.         }
  145.         else {
  146.         $_ .= ".t" unless /\.t$/;
  147.         push(@tests, $_);
  148.         }
  149.     }
  150.     }
  151.     else {
  152.         if ($args->{tdirs}) {
  153.             push @tests, map { sort <$base/$_/*.t> } @{ $args->{tdirs} };
  154.         }
  155.         else {
  156.             finddepth(sub {
  157.                           return unless /\.t$/;
  158.                           my $t = catfile $File::Find::dir, $_;
  159.                           my $dotslash = catfile '.', "";
  160.                           $t =~ s:^\Q$dotslash::;
  161.                           push @tests, $t
  162.                       }, $base);
  163.             @tests = sort @tests;
  164.         }
  165.     }
  166.  
  167.     @tests = $self->prune(@tests);
  168.  
  169.     if (my $skip = $self->skip) {
  170.         @tests = grep { not /(?:$skip)/ } @tests;
  171.     }
  172.  
  173.     Apache::TestSort->run(\@tests, $args);
  174.  
  175.     #when running 't/TEST t/dir' shell tab completion adds a /
  176.     #dir//foo output is annoying, fix that.
  177.     s:/+:/:g for @tests;
  178.  
  179.     return @tests;
  180. }
  181.  
  182. sub run {
  183.     my $self = shift;
  184.     my $args = shift || {};
  185.  
  186.     $Test::Harness::verbose ||= $args->{verbose};
  187.  
  188.     if (my(@subtests) = @{ $args->{subtests} || [] }) {
  189.         $ENV{HTTPD_TEST_SUBTESTS} = "@subtests";
  190.     }
  191.  
  192.     Test::Harness::runtests($self->get_tests($args, @_));
  193. }
  194.  
  195. 1;
  196.