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 / TestConfigParse.pm < prev    next >
Encoding:
Perl POD Document  |  2004-08-20  |  13.1 KB  |  470 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 TestConfigParse on purpose
  16.  
  17. #dont really want/need a full-blown parser
  18. #but do want something somewhat generic
  19.  
  20. use strict;
  21. use warnings FATAL => 'all';
  22.  
  23. use Apache::TestTrace;
  24.  
  25. use File::Spec::Functions qw(rel2abs splitdir file_name_is_absolute);
  26. use File::Basename qw(dirname basename);
  27.  
  28. sub strip_quotes {
  29.     local $_ = shift || $_;
  30.     s/^\"//; s/\"$//; $_;
  31. }
  32.  
  33. my %wanted_config = (
  34.     TAKE1 => {map { $_, 1 } qw(ServerRoot ServerAdmin TypesConfig DocumentRoot)},
  35.     TAKE2 => {map { $_, 1 } qw(LoadModule)},
  36. );
  37.  
  38. my %spec_init = (
  39.     TAKE1 => sub { shift->{+shift} = "" },
  40.     TAKE2 => sub { shift->{+shift} = [] },
  41. );
  42.  
  43. my %spec_apply = (
  44.     TypesConfig => \&inherit_server_file,
  45.     ServerRoot  => sub {}, #dont override $self->{vars}->{serverroot}
  46.     DocumentRoot => \&inherit_directive_var,
  47.     LoadModule  => \&inherit_load_module,
  48. );
  49.  
  50. #where to add config, default is preamble
  51. my %spec_postamble = map { $_, 'postamble' } qw(TypesConfig);
  52.  
  53. sub spec_add_config {
  54.     my($self, $directive, $val) = @_;
  55.  
  56.     my $where = $spec_postamble{$directive} || 'preamble';
  57.     $self->$where($directive => $val);
  58. }
  59.  
  60. # resolve relative files like Apache->server_root_relative
  61. # this function doesn't test whether the resolved file exists
  62. sub server_file_rel2abs {
  63.     my($self, $file, $base) = @_;
  64.  
  65.     my ($serverroot, $result) = ();
  66.  
  67.     # order search sequence
  68.     my @tries = ([ $base,
  69.                        'user-supplied $base' ],
  70.                  [ $self->{inherit_config}->{ServerRoot},
  71.                        'httpd.conf inherited ServerRoot' ],
  72.                  [ $self->apxs('PREFIX'),
  73.                        'apxs-derived ServerRoot' ]);
  74.  
  75.     # remove surrounding quotes if any
  76.     # e.g. Include "/tmp/foo.html"
  77.     $file =~ s/^\s*["']?//;
  78.     $file =~ s/["']?\s*$//;
  79.  
  80.     if (file_name_is_absolute($file)) {
  81.         debug "$file is already absolute";
  82.         $result = $file;
  83.     }
  84.     else {
  85.         foreach my $try (@tries) {
  86.             next unless defined $try->[0];
  87.  
  88.             if (-d $try->[0]) {
  89.                 $serverroot = $try->[0];
  90.                 debug "using $try->[1] to resolve $file";
  91.                 last;
  92.             }
  93.         }
  94.  
  95.         if ($serverroot) {
  96.             $result = rel2abs $file, $serverroot;
  97.         }
  98.         else {
  99.             warning "unable to resolve $file - cannot find a suitable ServerRoot";
  100.             warning "please specify a ServerRoot in your httpd.conf or use apxs";
  101.  
  102.             # return early, skipping file test below
  103.             return $file;
  104.         }
  105.     }
  106.  
  107.     my $dir = dirname $result;
  108.     # $file might not exist (e.g. if it's a glob pattern like
  109.     # "conf/*.conf" but what we care about here is to check whether
  110.     # the base dir was successfully resolved. we don't check whether
  111.     # the file exists at all. it's the responsibility of the caller to
  112.     # do this check
  113.     if (defined $dir && -e $dir && -d _) {
  114.         if (-e $result) {
  115.             debug "$file successfully resolved to existing file $result";
  116.         }
  117.         else {
  118.             debug "base dir of '$file' successfully resolved to $dir";
  119.         }
  120.  
  121.     }
  122.     else {
  123.         $dir ||= '';
  124.         warning "dir '$dir' does not exist (while resolving '$file')";
  125.  
  126.         # old behavior was to return the resolved but non-existent
  127.         # file.  preserve that behavior and return $result anyway.
  128.     }
  129.  
  130.     return $result;
  131. }
  132.  
  133. sub server_file {
  134.     my $f = shift->server_file_rel2abs(@_);
  135.     return qq("$f");
  136. }
  137.  
  138. sub inherit_directive_var {
  139.     my($self, $c, $directive) = @_;
  140.  
  141.     $self->{vars}->{"inherit_\L$directive"} = $c->{$directive};
  142. }
  143.  
  144. sub inherit_server_file {
  145.     my($self, $c, $directive) = @_;
  146.  
  147.     $self->spec_add_config($directive,
  148.                            $self->server_file($c->{$directive}));
  149. }
  150.  
  151. #so we have the same names if these modules are linked static or shared
  152. my %modname_alias = (
  153.     'mod_pop.c'            => 'pop_core.c',
  154.     'mod_proxy_http.c'     => 'proxy_http.c',
  155.     'mod_proxy_ftp.c'      => 'proxy_ftp.c',
  156.     'mod_proxy_balancer.c' => 'proxy_balancer.c',
  157.     'mod_proxy_connect.c'  => 'proxy_connect.c',
  158.     'mod_modperl.c'        => 'mod_perl.c',
  159. );
  160.  
  161. #XXX mod_jk requires JkWorkerFile or JkWorker to be configured
  162. #skip it for now, tomcat has its own test suite anyhow.
  163. #XXX: mod_casp2.so requires other settings in addition to LoadModule
  164. my %autoconfig_skip_module = map { $_, 1 } qw(mod_jk.c mod_casp2.c);
  165.  
  166. # add modules to be not inherited from the existing config.
  167. # e.g. prevent from LoadModule perl_module to be included twice, when
  168. # mod_perl already configures LoadModule and it's certainly found in
  169. # the existing httpd.conf installed system-wide.
  170. sub autoconfig_skip_module_add {
  171.     my($name) = @_;
  172.     $autoconfig_skip_module{$name} = 1;
  173. }
  174.  
  175. sub should_skip_module {
  176.     my($self, $name) = @_;
  177.     return $autoconfig_skip_module{$name} ? 1 : 0;
  178. }
  179.  
  180. #inherit LoadModule
  181. sub inherit_load_module {
  182.     my($self, $c, $directive) = @_;
  183.  
  184.     for my $args (@{ $c->{$directive} }) {
  185.         my $modname = $args->[0];
  186.         my $file = $self->server_file_rel2abs($args->[1]);
  187.  
  188.         unless (-e $file) {
  189.             debug "$file does not exist, skipping LoadModule";
  190.             next;
  191.         }
  192.  
  193.         my $name = basename $args->[1];
  194.         $name =~ s/\.s[ol]$/.c/;  #mod_info.so => mod_info.c
  195.         $name =~ s/^lib/mod_/; #libphp4.so => mod_php4.c
  196.  
  197.         $name = $modname_alias{$name} if $modname_alias{$name};
  198.  
  199.         # remember all found modules
  200.         $self->{modules}->{$name} = $file;
  201.         debug "Found: $modname => $name";
  202.  
  203.         if ($self->should_skip_module($name)) {
  204.             debug "Skipping LoadModule of $name";
  205.             next;
  206.         }
  207.  
  208.         debug "LoadModule $modname $name";
  209.  
  210.         # sometimes people have broken system-wide httpd.conf files,
  211.         # which include LoadModule of modules, which are built-in, but
  212.         # won't be skipped above if they are found in the modules/
  213.         # directory. this usually happens when httpd is built once
  214.         # with its modules built as shared objects and then again with
  215.         # static ones: the old httpd.conf still has the LoadModule
  216.         # directives, even though the modules are now built-in
  217.         # so we try to workaround this problem using <IfModule>
  218.         $self->preamble(IfModule => "!$name",
  219.                         qq{LoadModule $modname "$file"\n});
  220.     }
  221. }
  222.  
  223. sub parse_take1 {
  224.     my($self, $c, $directive) = @_;
  225.     $c->{$directive} = strip_quotes;
  226. }
  227.  
  228. sub parse_take2 {
  229.     my($self, $c, $directive) = @_;
  230.     push @{ $c->{$directive} }, [map { strip_quotes } split];
  231. }
  232.  
  233. sub apply_take1 {
  234.     my($self, $c, $directive) = @_;
  235.  
  236.     if (exists $self->{vars}->{lc $directive}) {
  237.         #override replacement @Variables@
  238.         $self->{vars}->{lc $directive} = $c->{$directive};
  239.     }
  240.     else {
  241.         $self->spec_add_config($directive, qq("$c->{$directive}"));
  242.     }
  243. }
  244.  
  245. sub apply_take2 {
  246.     my($self, $c, $directive) = @_;
  247.  
  248.     for my $args (@{ $c->{$directive} }) {
  249.         $self->spec_add_config($directive => [map { qq("$_") } @$args]);
  250.     }
  251. }
  252.  
  253. sub inherit_config_file_or_directory {
  254.     my ($self, $item) = @_;
  255.  
  256.     if (-d $item) {
  257.         my $dir = $item;
  258.         debug "descending config directory: $dir";
  259.  
  260.         for my $entry (glob "$dir/*") {
  261.             $self->inherit_config_file_or_directory($entry);
  262.         }
  263.         return;
  264.     }
  265.  
  266.     my $file = $item;
  267.     debug "inheriting config file: $file";
  268.  
  269.     my $fh = Symbol::gensym();
  270.     open($fh, $file) or return;
  271.  
  272.     my $c = $self->{inherit_config};
  273.     while (<$fh>) {
  274.         s/^\s*//; s/\s*$//; s/^\#.*//;
  275.         next if /^$/;
  276.  
  277.         # support continuous config lines (which use \ to break the line)
  278.         while (s/\\$//) {
  279.             my $cont = <$fh>;
  280.             $cont =~ s/^\s*//;
  281.             $cont =~ s/\s*$//;
  282.             $_ .= $cont;
  283.         }
  284.  
  285.         (my $directive, $_) = split /\s+/, $_, 2;
  286.  
  287.         if ($directive eq "Include") {
  288.             foreach my $include (glob($self->server_file_rel2abs($_))) {
  289.                 $self->inherit_config_file_or_directory($include);
  290.             }
  291.         }
  292.  
  293.         #parse what we want
  294.         while (my($spec, $wanted) = each %wanted_config) {
  295.             next unless $wanted->{$directive};
  296.             my $method = "parse_\L$spec";
  297.             $self->$method($c, $directive);
  298.         }
  299.     }
  300.  
  301.     close $fh;
  302. }
  303.  
  304. sub inherit_config {
  305.     my $self = shift;
  306.  
  307.     $self->get_httpd_static_modules;
  308.     $self->get_httpd_defines;
  309.  
  310.     #may change after parsing httpd.conf
  311.     $self->{vars}->{inherit_documentroot} =
  312.       catfile $self->{httpd_basedir}, 'htdocs';
  313.  
  314.     my $file = $self->{vars}->{httpd_conf};
  315.     my $extra_file = $self->{vars}->{httpd_conf_extra};
  316.  
  317.     unless ($file and -e $file) {
  318.         if (my $base = $self->{httpd_basedir}) {
  319.             my $default_conf = $self->{httpd_defines}->{SERVER_CONFIG_FILE};
  320.             $default_conf ||= catfile qw(conf httpd.conf);
  321.             $file = catfile $base, $default_conf;
  322.             # SERVER_CONFIG_FILE might be an absolute path
  323.             $file = $default_conf if !-e $file and -e $default_conf;
  324.         }
  325.     }
  326.  
  327.     unless ($extra_file and -e $extra_file) {
  328.         if ($extra_file and my $base = $self->{httpd_basedir}) {
  329.             my $default_conf = catfile qw(conf $extra_file);
  330.             $extra_file = catfile $base, $default_conf;
  331.             # SERVER_CONFIG_FILE might be an absolute path
  332.             $extra_file = $default_conf if !-e $extra_file and -e $default_conf;
  333.         }
  334.     }
  335.  
  336.     return unless $file or $extra_file;
  337.  
  338.     my $c = $self->{inherit_config};
  339.  
  340.     #initialize array refs and such
  341.     while (my($spec, $wanted) = each %wanted_config) {
  342.         for my $directive (keys %$wanted) {
  343.             $spec_init{$spec}->($c, $directive);
  344.         }
  345.     }
  346.  
  347.     $self->inherit_config_file_or_directory($file) if $file;
  348.     $self->inherit_config_file_or_directory($extra_file) if $extra_file;
  349.  
  350.     #apply what we parsed
  351.     while (my($spec, $wanted) = each %wanted_config) {
  352.         for my $directive (keys %$wanted) {
  353.             next unless $c->{$directive};
  354.             my $cv = $spec_apply{$directive} ||
  355.                      $self->can("apply_\L$directive") ||
  356.                      $self->can("apply_\L$spec");
  357.             $cv->($self, $c, $directive);
  358.         }
  359.     }
  360. }
  361.  
  362. sub get_httpd_static_modules {
  363.     my $self = shift;
  364.  
  365.     my $httpd = $self->{vars}->{httpd};
  366.     return unless $httpd;
  367.  
  368.     $httpd = shell_ready($httpd);
  369.     my $cmd = "$httpd -l";
  370.     my $list = $self->open_cmd($cmd);
  371.  
  372.     while (<$list>) {
  373.         s/\s+$//;
  374.         next unless /\.c$/;
  375.         chomp;
  376.         s/^\s+//;
  377.         $self->{modules}->{$_} = 1;
  378.     }
  379.  
  380.     close $list;
  381. }
  382.  
  383. sub get_httpd_defines {
  384.     my $self = shift;
  385.  
  386.     my $httpd = $self->{vars}->{httpd};
  387.     return unless $httpd;
  388.  
  389.     $httpd = shell_ready($httpd);
  390.     my $cmd = "$httpd -V";
  391.     my $proc = $self->open_cmd($cmd);
  392.  
  393.     while (<$proc>) {
  394.         chomp;
  395.         if( s/^\s*-D\s*//) {
  396.             s/\s+$//;
  397.             my($key, $val) = split '=', $_, 2;
  398.             $self->{httpd_defines}->{$key} = $val ? strip_quotes($val) : 1;
  399.             debug "isolated httpd_defines $key = " . $self->{httpd_defines}->{$key};
  400.         }
  401.         elsif (/(version|built|module magic number|server mpm):\s+(.*)/i) {
  402.             my $val = $2;
  403.             (my $key = uc $1) =~ s/\s/_/g;
  404.             $self->{httpd_info}->{$key} = $val;
  405.             debug "isolated httpd_info $key = " . $val;
  406.         }
  407.     }
  408.  
  409.     close $proc;
  410.  
  411.     if (my $mmn = $self->{httpd_info}->{MODULE_MAGIC_NUMBER}) {
  412.         @{ $self->{httpd_info} }
  413.           {qw(MODULE_MAGIC_NUMBER_MAJOR
  414.               MODULE_MAGIC_NUMBER_MINOR)} = split ':', $mmn;
  415.     }
  416.  
  417.     # get the mpm information where available
  418.     # lowercase for consistency across the two extraction methods
  419.     # XXX or maybe consider making have_apache_mpm() case-insensitive?
  420.     if (my $mpm = $self->{httpd_info}->{SERVER_MPM}) {
  421.         # 2.1
  422.         $self->{mpm} = lc $mpm;
  423.     }
  424.     elsif (my $mpm_dir = $self->{httpd_defines}->{APACHE_MPM_DIR}) {
  425.         # 2.0
  426.         $self->{mpm} = lc basename $mpm_dir;
  427.     }
  428.     else {
  429.         # Apache 1.3 - no mpm to speak of
  430.         $self->{mpm} = '';
  431.     }
  432. }
  433.  
  434. sub httpd_version {
  435.     my $self = shift;
  436.  
  437.     my $httpd = $self->{vars}->{httpd};
  438.     return unless $httpd;
  439.  
  440.     my $version;
  441.     $httpd = shell_ready($httpd);
  442.     my $cmd = "$httpd -v";
  443.  
  444.     my $v = $self->open_cmd($cmd);
  445.  
  446.     local $_;
  447.     while (<$v>) {
  448.         next unless s/^Server\s+version:\s*//i;
  449.         chomp;
  450.         my @parts = split;
  451.         foreach (@parts) {
  452.             next unless /^Apache\//;
  453.             $version = $_;
  454.             last;
  455.         }
  456.         $version ||= $parts[0];
  457.         last;
  458.     }
  459.  
  460.     close $v;
  461.  
  462.     return $version;
  463. }
  464.  
  465. sub httpd_mpm {
  466.     return shift->{mpm};
  467. }
  468.  
  469. 1;
  470.