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