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