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 / TestConfigPerl.pm < prev    next >
Encoding:
Perl POD Document  |  2003-10-22  |  17.6 KB  |  589 lines
  1. package Apache::TestConfig; #not TestConfigPerl on purpose
  2.  
  3. #things specific to mod_perl
  4.  
  5. use strict;
  6. use warnings FATAL => 'all';
  7. use File::Spec::Functions qw(catfile splitdir abs2rel file_name_is_absolute);
  8. use File::Find qw(finddepth);
  9. use Apache::TestTrace;
  10. use Apache::TestRequest;
  11. use Config;
  12.  
  13. my %libmodperl  = (1 => 'libperl.so', 2 => 'mod_perl.so');
  14.  
  15. sub configure_libmodperl {
  16.     my $self = shift;
  17.  
  18.     my $server = $self->{server};
  19.     my $libname = $server->version_of(\%libmodperl);
  20.     my $vars = $self->{vars};
  21.  
  22.     if ($vars->{libmodperl}) {
  23.         # if set, libmodperl was specified from the command line and
  24.         # should be used instead of the one that is looked up
  25.  
  26.         # resolve a non-absolute path
  27.         $vars->{libmodperl} = $self->find_apache_module($vars->{libmodperl})
  28.             unless file_name_is_absolute($vars->{libmodperl});
  29.     }
  30.     # $server->{rev} could be set to 2 as a fallback, even when
  31.     # the wanted version is 1. So check that we use mod_perl 2
  32.     elsif ($server->{rev} >= 2 && IS_MOD_PERL_2) {
  33.         if (my $build_config = $self->modperl_build_config()) {
  34.             if ($build_config->{MODPERL_LIB_SHARED}) {
  35.                 $libname = $build_config->{MODPERL_LIB_SHARED};
  36.                 $vars->{libmodperl} ||= $self->find_apache_module($libname);
  37.             }
  38.             # XXX: we have a problem with several perl trees pointing
  39.             # to the same httpd tree. So it's possible that we
  40.             # configure the test suite to run with mod_perl.so built
  41.             # against perl which it wasn't built with. Should we use
  42.             # something like ldd to check the match?
  43.         }
  44.         else {
  45.             # XXX: can we test whether mod_perl was linked statically
  46.             # so we don't need to preload it
  47.             # if (!linked statically) {
  48.             #     die "can't find mod_perl built for perl version $]"
  49.             # }
  50.             error "can't find mod_perl.so built for perl version $]";
  51.         }
  52.         # don't use find_apache_module or we may end up with the wrong
  53.         # shared object, built against different perl
  54.     }
  55.     else {
  56.         # mod_perl 1.0
  57.         $vars->{libmodperl} ||= $self->find_apache_module($libname);
  58.         # XXX: how do we find out whether we have a static or dynamic
  59.         # mod_perl build? die if its dynamic and can't find the module
  60.     }
  61.  
  62.     my $cfg = '';
  63.  
  64.     if ($vars->{libmodperl} && -e $vars->{libmodperl}) {
  65.         if (Apache::TestConfig::WIN32) {
  66.             my $lib = "$Config{installbin}\\$Config{libperl}";
  67.             $lib =~ s/lib$/dll/;
  68.             $cfg = 'LoadFile ' . qq("$lib"\n) if -e $lib;
  69.     }
  70.         # add the module we found to the cached modules list
  71.         # otherwise have_module('mod_perl') doesn't work unless
  72.         # we have a LoadModule in our base config
  73.         $self->{modules}->{'mod_perl.c'} = $vars->{libmodperl};
  74.  
  75.         $cfg .= 'LoadModule ' . qq(perl_module "$vars->{libmodperl}"\n);
  76.     }
  77.     else {
  78.         my $msg = "unable to locate $libname (could be a static build)\n";
  79.         $cfg = "#$msg";
  80.         debug $msg;
  81.     }
  82.     $self->preamble(IfModule => '!mod_perl.c', $cfg);
  83. }
  84.  
  85. sub configure_inc {
  86.     my $self = shift;
  87.  
  88.     my $top = $self->{vars}->{top_dir};
  89.  
  90.     my $inc = $self->{inc};
  91.     my @trys = (catdir($top, qw(blib lib)),
  92.                 catdir($top, qw(blib arch)));
  93.  
  94.     for (@trys) {
  95.         push @$inc, $_ if -d $_;
  96.     }
  97.  
  98.     # spec: If PERL5LIB is defined, PERLLIB is not used.
  99.     for (qw(PERL5LIB PERLLIB)) {
  100.         next unless exists $ENV{$_};
  101.         push @$inc, split /$Config{path_sep}/, $ENV{$_};
  102.         last;
  103.     }
  104.  
  105.     # enable live testing of the Apache-Test dev modules if they are
  106.     # located at the project's root dir
  107.     my $apache_test_dev_dir = catfile($top, 'Apache-Test', 'lib');
  108.     unshift @$inc, $apache_test_dev_dir if -d $apache_test_dev_dir;
  109. }
  110.  
  111. sub write_pm_test {
  112.     my($self, $module, $base, $sub) = @_;
  113.  
  114.     my $dir = catfile $self->{vars}->{t_dir}, $base;
  115.     my $t = catfile $dir, "$sub.t";
  116.     return if -e $t;
  117.  
  118.     $self->gendir($dir);
  119.     my $fh = $self->genfile($t);
  120.  
  121.     my $path = Apache::TestRequest::module2path($module);
  122.  
  123.     print $fh <<EOF;
  124. use Apache::TestRequest 'GET_BODY_ASSERT';
  125. print GET_BODY_ASSERT "/$path";
  126. EOF
  127.  
  128.     close $fh or die "close $t: $!";
  129. }
  130.  
  131. # propogate trace overrides to the server
  132. sub configure_trace {
  133.     my $self = shift;
  134.     $self->postamble(IfModule => 'mod_perl.c',
  135.                      "PerlPassEnv APACHE_TEST_TRACE_LEVEL\n");
  136. }
  137.  
  138. sub startup_pl_code {
  139.     my $self = shift;
  140.     my $serverroot = $self->{vars}->{serverroot};
  141.  
  142.     return <<"EOF";
  143. BEGIN {
  144.     use lib '$serverroot';
  145.     for my \$file (qw(modperl_inc.pl modperl_extra.pl)) {
  146.         eval { require "conf/\$file" } or
  147.             die if grep { -e "\$_/conf/\$file" } \@INC;
  148.     }
  149. }
  150.  
  151. 1;
  152. EOF
  153. }
  154.  
  155. sub configure_startup_pl {
  156.     my $self = shift;
  157.  
  158.     #for 2.0 we could just use PerlSwitches -Mlib=...
  159.     #but this will work for both 2.0 and 1.xx
  160.     if (my $inc = $self->{inc}) {
  161.         my $include_pl = catfile $self->{vars}->{t_conf}, 'modperl_inc.pl';
  162.         my $fh = $self->genfile($include_pl);
  163.         for (reverse @$inc) {
  164.             print $fh "use lib '$_';\n";
  165.         }
  166.         my $fixup = Apache::TestConfig->modperl_2_inc_fixup();
  167.         print $fh $fixup;
  168.  
  169.         # if Apache::Test is used to develop a project, we want the
  170.         # project/lib directory to be first in @INC (loaded last)
  171.         if ($ENV{APACHE_TEST_LIVE_DEV}) {
  172.             my $dev_lib = catdir $self->{vars}->{top_dir}, "lib";
  173.             print $fh "use lib '$dev_lib';\n" if -d $dev_lib;
  174.         }
  175.  
  176.         print $fh "1;\n";
  177.     }
  178.  
  179.     if ($self->server->{rev} >= 2) {
  180.         $self->postamble(IfModule => 'mod_perl.c',
  181.                          "PerlSwitches -Mlib=$self->{vars}->{serverroot}\n");
  182.     }
  183.  
  184.     my $startup_pl = catfile $self->{vars}->{t_conf}, 'modperl_startup.pl';
  185.  
  186.     unless (-e $startup_pl) {
  187.         my $fh = $self->genfile($startup_pl);
  188.         print $fh $self->startup_pl_code;
  189.         close $fh;
  190.     }
  191.  
  192.     $self->postamble(IfModule => 'mod_perl.c',
  193.                      "PerlRequire $startup_pl\n");
  194. }
  195.  
  196. my %sethandler_modperl = (1 => 'perl-script', 2 => 'modperl');
  197.  
  198. sub set_handler {
  199.     my($self, $module, $args) = @_;
  200.     return if grep { $_ eq 'SetHandler' } @$args;
  201.  
  202.     push @$args,
  203.       SetHandler =>
  204.         $self->server->version_of(\%sethandler_modperl);
  205. }
  206.  
  207. sub set_connection_handler {
  208.     my($self, $module, $args) = @_;
  209.     my $port = $self->new_vhost($module);
  210.     $self->postamble(Listen => $port);
  211. }
  212.  
  213. my %add_hook_config = (
  214.     Response          => \&set_handler,
  215.     ProcessConnection => \&set_connection_handler,
  216.     PreConnection     => \&set_connection_handler,
  217. );
  218.  
  219. my %container_config = (
  220.     ProcessConnection => \&vhost_container,
  221.     PreConnection     => \&vhost_container,
  222. );
  223.  
  224. sub location_container {
  225.     my($self, $module) = @_;
  226.     my $path = Apache::TestRequest::module2path($module);
  227.     Location => "/$path";
  228. }
  229.  
  230. sub vhost_container {
  231.     my($self, $module) = @_;
  232.     my $port = $self->{vhosts}->{$module}->{port};
  233.     my $namebased = $self->{vhosts}->{$module}->{namebased};
  234.  
  235.     VirtualHost => ($namebased ? '*' : '_default_') . ":$port";
  236. }
  237.  
  238. sub new_vhost {
  239.     my($self, $module, $namebased) = @_;
  240.     my($port, $servername, $vhost);
  241.  
  242.     unless ($namebased and exists $self->{vhosts}->{$module}) {
  243.         $port       = $self->server->select_port;
  244.         $vhost      = $self->{vhosts}->{$module} = {};
  245.  
  246.         $vhost->{port}       = $port;
  247.         $vhost->{namebased}  = $namebased ? 1 : 0;
  248.     }
  249.     else {
  250.         $vhost      = $self->{vhosts}->{$module};
  251.         $port       = $vhost->{port};
  252.         # remember the already configured Listen/NameVirtualHost
  253.         $vhost->{namebased}++;
  254.     }
  255.  
  256.     $servername = $self->{vars}->{servername};
  257.  
  258.     $vhost->{servername} = $servername;
  259.     $vhost->{name}       = join ':', $servername, $port;
  260.     $vhost->{hostport}   = $self->hostport($vhost, $module);
  261.  
  262.     $port;
  263. }
  264.  
  265. my %outside_container = map { $_, 1 } qw{
  266. Alias AliasMatch AddType
  267. PerlChildInitHandler PerlTransHandler PerlPostReadRequestHandler
  268. PerlSwitches PerlRequire PerlModule
  269. };
  270.  
  271. my %strip_tags = map { $_ => 1} qw(base noautoconfig);
  272.  
  273. #test .pm's can have configuration after the __DATA__ token
  274. sub add_module_config {
  275.     my($self, $module, $args) = @_;
  276.     my $fh = Symbol::gensym();
  277.     open($fh, $module) or return;
  278.  
  279.     while (<$fh>) {
  280.         last if /^(__(DATA|END)__|\#if CONFIG_FOR_HTTPD_TEST)/;
  281.     }
  282.  
  283.     my %directives;
  284.  
  285.     while (<$fh>) {
  286.         last if /^\#endif/; #for .c modules
  287.         next unless /\S+/;
  288.         chomp;
  289.         s/^\s+//;
  290.         $self->replace;
  291.         if (/^#/) {
  292.             # preserve comments
  293.             $self->postamble($_);
  294.             next;
  295.         }
  296.         my($directive, $rest) = split /\s+/, $_, 2;
  297.         $directives{$directive}++ unless $directive =~ /^</;
  298.         $rest = '' unless defined $rest;
  299.  
  300.         if ($outside_container{$directive}) {
  301.             $self->postamble($directive => $rest);
  302.         }
  303.         elsif ($directive =~ /IfModule/) {
  304.             $self->postamble($_);
  305.         }
  306.         elsif ($directive =~ m/^<(\w+)/) {
  307.             # strip special container directives like <Base> and </Base>
  308.             my $strip_container = exists $strip_tags{lc $1} ? 1 : 0;
  309.  
  310.             $directives{noautoconfig}++ if lc($1) eq 'noautoconfig';
  311.  
  312.             my $indent = '';
  313.             $self->process_container($_, $fh, lc($1),
  314.                                      $strip_container, $indent);
  315.         }
  316.         else {
  317.             push @$args, $directive, $rest;
  318.         }
  319.     }
  320.  
  321.     \%directives;
  322. }
  323.  
  324.  
  325. # recursively process the directives including nested containers,
  326. # re-indent 4 and ucfirst the closing tags letter
  327. sub process_container {
  328.     my($self, $first_line, $fh, $directive, $strip_container, $indent) = @_;
  329.  
  330.     my $new_indent = $indent;
  331.  
  332.     unless ($strip_container) {
  333.         $new_indent .= "    ";
  334.  
  335.         local $_ = $first_line;
  336.         s/^\s*//;
  337.         $self->replace;
  338.  
  339.         if (/<VirtualHost/) {
  340.             $self->process_vhost_open_tag($_, $indent);
  341.         }
  342.         else {
  343.             $self->postamble($indent . $_);
  344.         }
  345.     }
  346.  
  347.     $self->process_container_remainder($fh, $directive, $new_indent);
  348.  
  349.     unless ($strip_container) {
  350.         $self->postamble($indent . "</\u$directive>");
  351.     }
  352.  
  353. }
  354.  
  355.  
  356. # processes the body of the container without the last line, including
  357. # the end tag
  358. sub process_container_remainder {
  359.     my($self, $fh, $directive, $indent) = @_;
  360.  
  361.     my $end_tag = "</$directive>";
  362.  
  363.     while (<$fh>) {
  364.         chomp;
  365.         last if m|^\s*\Q$end_tag|i;
  366.         s/^\s*//;
  367.         $self->replace;
  368.  
  369.         if (m/^\s*<(\w+)/) {
  370.             $self->process_container($_, $fh, $1, 0, $indent);
  371.         }
  372.         else {
  373.             $self->postamble($indent . $_);
  374.         }
  375.     }
  376. }
  377.  
  378. # does the necessary processing to create a vhost container header
  379. sub process_vhost_open_tag {
  380.     my($self, $line, $indent) = @_;
  381.  
  382.     my $cfg = $self->parse_vhost($line);
  383.  
  384.     if ($cfg) {
  385.         my $port = $cfg->{port};
  386.         $cfg->{out_postamble}->();
  387.         $self->postamble($cfg->{line});
  388.         $cfg->{in_postamble}->();
  389.     } else {
  390.         $self->postamble("$indent$line");
  391.     }
  392. }
  393.  
  394. #the idea for each group:
  395. # Response: there will be many of these, mostly modules to test the API
  396. #           that plan tests => ... and output with ok()
  397. #           the naming allows grouping, making it easier to run an
  398. #           individual set of tests, e.g. t/TEST t/apr
  399. #           the PerlResponseHandler and SetHandler modperl is auto-configured
  400. # Hooks:    for testing the simpler Perl*Handlers
  401. #           auto-generates the Perl*Handler config
  402. # Protocol: protocol modules need their own port/vhost to listen on
  403.  
  404. #@INC is auto-modified so each test .pm can be found
  405. #modules can add their own configuration using __DATA__
  406.  
  407. my %hooks = map { $_, ucfirst $_ }
  408.     qw(init trans headerparser access authen authz type fixup log);
  409. $hooks{Protocol} = 'ProcessConnection';
  410. $hooks{Filter}   = 'OutputFilter';
  411.  
  412. my @extra_subdirs = qw(Response Protocol PreConnection Hooks Filter);
  413.  
  414. # add the subdirs to @INC early, in case mod_perl is started earlier
  415. sub configure_pm_tests_inc {
  416.     my $self = shift;
  417.     for my $subdir (@extra_subdirs) {
  418.         my $dir = catfile $self->{vars}->{t_dir}, lc $subdir;
  419.         next unless -d $dir;
  420.  
  421.         push @{ $self->{inc} }, $dir;
  422.     }
  423. }
  424.  
  425. # @status fields
  426. use constant APACHE_TEST_CONFIGURE    => 0;
  427. use constant APACHE_TEST_CONFIG_ORDER => 1;
  428.  
  429. sub configure_pm_tests_pick {
  430.     my($self, $entries) = @_;
  431.  
  432.     for my $subdir (@extra_subdirs) {
  433.         my $dir = catfile $self->{vars}->{t_dir}, lc $subdir;
  434.         next unless -d $dir;
  435.  
  436.         finddepth(sub {
  437.             return unless /\.pm$/;
  438.  
  439.             my $file = catfile $File::Find::dir, $_;
  440.             my $module = abs2rel $file, $dir;
  441.             my $status = $self->run_apache_test_config_scan($file);
  442.             push @$entries, [$file, $module, $subdir, $status];
  443.         }, $dir);
  444.     }
  445. }
  446.  
  447.  
  448. # a simple numerical order is performed and configuration sections are
  449. # inserted using that order. If the test package specifies no special
  450. # token that matches /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/ anywhere
  451. # in the file, 0 is assigned as its order. If the token is specified,
  452. # config section with negative values will be inserted first, with
  453. # positive last. By using different values you can arrange for the
  454. # test configuration sections to be inserted in any desired order
  455. sub configure_pm_tests_sort {
  456.     my($self, $entries) = @_;
  457.  
  458.     @$entries = sort {
  459.         $a->[3]->[APACHE_TEST_CONFIG_ORDER] <=>
  460.         $b->[3]->[APACHE_TEST_CONFIG_ORDER]
  461.     } @$entries;
  462.  
  463. }
  464.  
  465. sub configure_pm_tests {
  466.     my $self = shift;
  467.  
  468.     # since server wasn't started yet, the modules in blib under
  469.     # Apache2 can't be seen. So we must load Apache2.pm, without which
  470.     # run_apache_test_config might fail to require modules
  471.     require mod_perl;
  472.     if ($mod_perl::VERSION > 1.99) {
  473.         require Apache2;
  474.     }
  475.  
  476.     my @entries = ();
  477.     $self->configure_pm_tests_pick(\@entries);
  478.     $self->configure_pm_tests_sort(\@entries);
  479.  
  480.     for my $entry (@entries) {
  481.         my ($file, $module, $subdir, $status) = @$entry;
  482.         my @args = ();
  483.  
  484.         my $directives = $self->add_module_config($file, \@args);
  485.         $module =~ s,\.pm$,,;
  486.         $module =~ s/^[a-z]://i; #strip drive if any
  487.         $module = join '::', splitdir $module;
  488.  
  489.         $self->run_apache_test_configure($file, $module, $status);
  490.  
  491.         my($base, $sub) =
  492.             map { s/^test//i; $_ } split '::', $module;
  493.  
  494.         my $hook = ($subdir eq 'Hooks' ? $hooks{$sub} : '')
  495.             || $hooks{$subdir} || $subdir;
  496.  
  497.         if ($hook eq 'OutputFilter' and $module =~ /::i\w+$/) {
  498.             #XXX: tmp hack
  499.             $hook = 'InputFilter';
  500.         }
  501.  
  502.         my $handler = join $hook, qw(Perl Handler);
  503.  
  504.         if ($self->server->{rev} < 2 and lc($hook) eq 'response') {
  505.             $handler =~ s/response//i; #s/PerlResponseHandler/PerlHandler/
  506.         }
  507.  
  508.         debug "configuring $module";
  509.  
  510.         if ($directives->{noautoconfig}) {
  511.             $self->postamble(""); # which adds "\n"
  512.         }
  513.         else {
  514.             if (my $cv = $add_hook_config{$hook}) {
  515.                 $self->$cv($module, \@args);
  516.             }
  517.  
  518.             my $container = $container_config{$hook} || \&location_container;
  519.  
  520.             #unless the .pm test already configured the Perl*Handler
  521.             unless ($directives->{$handler}) {
  522.                 my @handler_cfg = ($handler => $module);
  523.  
  524.                 if ($outside_container{$handler}) {
  525.                     $self->postamble(@handler_cfg);
  526.                 } else {
  527.                     push @args, @handler_cfg;
  528.                 }
  529.             }
  530.  
  531.             $self->postamble($self->$container($module), \@args) if @args;
  532.         }
  533.  
  534.         $self->write_pm_test($module, lc $base, lc $sub);
  535.     }
  536. }
  537.  
  538. # scan tests for interesting information
  539. sub run_apache_test_config_scan {
  540.     my ($self, $file) = @_;
  541.  
  542.     my @status = ();
  543.     $status[APACHE_TEST_CONFIGURE]    = 0;
  544.     $status[APACHE_TEST_CONFIG_ORDER] = 0;
  545.  
  546.     my $fh = Symbol::gensym();
  547.     if (open $fh, $file) {
  548.         local $/;
  549.         my $content = <$fh>;
  550.         close $fh;
  551.         # XXX: optimize to match once?
  552.         if ($content =~ /APACHE_TEST_CONFIGURE/m) {
  553.             $status[APACHE_TEST_CONFIGURE] = 1;
  554.         }
  555.         if ($content =~ /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/m) {
  556.             $status[APACHE_TEST_CONFIG_ORDER] = int $1;
  557.         }
  558.     }
  559.     else {
  560.         error "cannot open $file: $!";
  561.     }
  562.  
  563.     return \@status;
  564. }
  565.  
  566. # We have to test whether tests have APACHE_TEST_CONFIGURE() in them
  567. # and run it if found at this stage, so when the server starts
  568. # everything is ready.
  569. # XXX: however we cannot use a simple require() because some tests
  570. # won't require() outside of mod_perl environment. Therefore we scan
  571. # the slurped file in.  and if APACHE_TEST_CONFIGURE has been found we
  572. # require the file and run this function.
  573. sub run_apache_test_configure {
  574.     my ($self, $file, $module, $status) = @_;
  575.  
  576.     return unless $status->[APACHE_TEST_CONFIGURE];
  577.  
  578.     eval { require $file };
  579.     warn $@ if $@;
  580.     # double check that it's a real sub
  581.     if ($module->can('APACHE_TEST_CONFIGURE')) {
  582.         eval { $module->APACHE_TEST_CONFIGURE($self); };
  583.         warn $@ if $@;
  584.     }
  585. }
  586.  
  587.  
  588. 1;
  589.