dougm 01/04/02 01:58:08 Added: Apache-Test/lib/Apache TestConfig.pm Log: base test config generator Revision Changes Path 1.1 modperl-2.0/Apache-Test/lib/Apache/TestConfig.pm Index: TestConfig.pm =================================================================== package Apache::TestConfig; use strict; use warnings FATAL => 'all'; use constant WIN32 => $^O eq 'MSWin32'; use File::Spec::Functions qw(catfile abs2rel splitdir); use Cwd qw(fastcwd); use Apache::TestConfigPerl (); use Apache::TestConfigParse (); use Apache::TestServer (); my %usage = ( top_dir => 'top-level directory (default is $PWD)', t_dir => 'the t/ test directory (default is $top_dir/t)', t_conf => 'the conf/ test directory (default is $t_dir/conf)', t_logs => 'the logs/ test directory (default is $t_dir/logs)', t_conf_file => 'test httpd.conf file (default is $t_conf/httpd.conf)', src_dir => 'source directory to look for mod_foos.so', serverroot => 'ServerRoot (default is $t_dir)', documentroot => 'DocumentRoot (default is $ServerRoot/htdocs', port => 'Port (default is 8529)', servername => 'ServerName (default is localhost)', user => 'User to run test server as (default is $USER)', group => 'Group to run test server as (default is $GROUP)', bindir => 'Apache bin/ dir (default is apxs -q SBINDIR)', httpd => 'server to use for testing (default is $bindir/httpd)', target => 'name of server binary (default is apxs -q TARGET)', apxs => 'location of apxs (default is from Apache::BuildConfig)', httpd_conf => 'inherit config from this file (default is apxs derived)', ); sub usage { for my $hash (\%usage) { while (my($key, $val) = each %$hash) { printf " %-16s %s\n", $key, $val; } } } my %passenv = map { $_,1 } qw{ APXS APACHE APACHE_GROUP APACHE_USER APACHE_PORT }; sub passenv { \%passenv; } sub server { shift->{server} } sub build_config { eval { require Apache::BuildConfig; } or return undef; return Apache::Build->build_config; } sub new_test_server { my($self, $args) = @_; Apache::TestServer->new($args || $self) } sub new { my($class, $args) = @_; $args = ($args and ref($args)) ? {%$args} : {@_}; #copy my $thaw = {}; #thaw current config for (qw(conf t/conf)) { last if eval { require "$_/apache_test_config.pm"; $thaw = 'apache_test_config'->new; delete $thaw->{save}; }; }; if ($args->{thaw}) { #dont generate any new config $thaw->{$_} = $args->{$_} for keys %$args; $thaw->{server} = $thaw->new_test_server; return $thaw; } #regenerating config, so forget old if ($args->{save}) { for (qw(vhosts inherit_config modules inc)) { delete $thaw->{$_} if exists $thaw->{$_}; } } my $self = bless { clean => {}, vhosts => {}, inherit_config => {}, modules => {}, inc => [], %$thaw, vars => $args, postamble => [], preamble => [], postamble_hooks => [], preamble_hooks => [], }, $class; my $vars = $self->{vars}; #things that can be overridden for (qw(save verbose)) { next unless exists $args->{$_}; $self->{$_} = delete $args->{$_}; } $vars->{top_dir} ||= fastcwd; $vars->{top_dir} = pop_dir($vars->{top_dir}, 't'); $self->add_inc; #help to find libmodperl.so my $src_dir = catfile $vars->{top_dir}, qw(src modules perl); $vars->{src_dir} ||= $src_dir if -d $src_dir; $vars->{t_dir} ||= catfile $vars->{top_dir}, 't'; $vars->{serverroot} ||= $vars->{t_dir}; $vars->{documentroot} ||= catfile $vars->{serverroot}, 'htdocs'; $vars->{t_conf} ||= catfile $vars->{serverroot}, 'conf'; $vars->{t_logs} ||= catfile $vars->{serverroot}, 'logs'; $vars->{t_conf_file} ||= catfile $vars->{t_conf}, 'httpd.conf'; $vars->{port} ||= $self->default_port; $vars->{servername} ||= $self->default_servername; $vars->{user} ||= $self->default_user; $vars->{group} ||= $self->default_group; $vars->{serveradmin} ||= join '@', $vars->{user}, $vars->{servername}; $self->configure_apxs; $self->configure_httpd; $self->inherit_config; #see TestConfigParse.pm $self->{hostport} = $self->hostport; $self->{server} = $self->new_test_server; $self; } sub configure_apxs { my $self = shift; return unless $self->{MP_APXS} = $self->default_apxs; my $vars = $self->{vars}; $vars->{bindir} ||= $self->apxs('SBINDIR'); $vars->{target} ||= $self->apxs('TARGET'); $vars->{conf_dir} ||= $self->apxs('SYSCONFDIR'); if ($vars->{conf_dir}) { $vars->{httpd_conf} ||= catfile $vars->{conf_dir}, 'httpd.conf'; } } sub configure_httpd { my $self = shift; my $vars = $self->{vars}; $vars->{target} ||= 'httpd'; if ($vars->{bindir}) { $vars->{httpd} ||= catfile $vars->{bindir}, $vars->{target}; } else { $vars->{httpd} ||= $self->default_httpd; } if ($vars->{httpd}) { my @chunks = splitdir $vars->{httpd}; pop @chunks for 1..2; #bin/httpd $self->{httpd_basedir} = catfile @chunks; } #cleanup httpd droppings my $sem = catfile $vars->{t_logs}, 'apache_runtime_status.sem'; unless (-e $sem) { $self->{clean}->{files}->{$sem} = 1; } } sub add_config { my $self = shift; my $where = shift; my($directive, $arg, $hash) = @_; my $args = ""; if ($hash) { $args = "<$directive $arg>\n"; if (ref($hash)) { while (my($k,$v) = each %$hash) { $args .= " $k $v\n"; } } else { $args .= " $hash"; } $args .= "</$directive>"; } elsif (ref($directive) eq 'ARRAY') { $args = join "\n", @$directive; } else { $args = "$directive " . (ref($arg) && (ref($arg) eq 'ARRAY') ? "@$arg" : $arg); } push @{ $self->{$where} }, $args; } sub postamble { shift->add_config(postamble => @_); } sub preamble { shift->add_config(preamble => @_); } sub postamble_register { push @{ shift->{postamble_hooks} }, @_; } sub preamble_register { push @{ shift->{preamble_hooks} }, @_; } sub add_config_hooks_run { my($self, $where, $out) = @_; for (@{ $self->{"${where}_hooks"} }) { $self->$_(); } for (@{ $self->{$where} }) { $self->replace; print $out "$_\n"; } } sub postamble_run { shift->add_config_hooks_run(postamble => @_); } sub preamble_run { shift->add_config_hooks_run(preamble => @_); } sub default_group { my $gid = $); #use only first value if $) contains more than one $gid =~ s/^(\d+).*$/$1/; WIN32 ? 'nogroup' : $ENV{APACHE_GROUP} || (getgrgid($gid) || "#$gid"); } sub default_user { my $uid = $>; my $user = WIN32 ? 'nobody' : $ENV{APACHE_USER} || (getpwuid($uid) || "#$uid"); if ($user eq 'root') { my $other = (getpwnam('nobody'))[0]; if ($other) { $user = $other; } else { die "cannot run tests as User root"; #XXX: prompt for another username } } $user; } sub default_apxs { my $self = shift; return $self->{vars}->{apxs} if $self->{vars}->{apxs}; if (my $build_config = build_config()) { return $build_config->{MP_APXS}; } $ENV{APXS} || which('apxs'); } sub default_httpd { my $vars = shift->{vars}; $ENV{APACHE} || which($vars->{target}); } sub default_servername { 'localhost'; } #XXX: could check if the port is in use and select another if so sub default_port { $ENV{APACHE_PORT} || 8529; } sub default_loopback { '127.0.0.1'; } sub port { my($self, $module) = @_; return $self->{vars}->{port} unless $module; return $self->{vhosts}->{$module}->{port}; } sub hostport { my $self = shift; my $vars = shift || $self->{vars}; my $name = $vars->{servername}; my $resolve = \$self->{resolved}->{$name}; unless ($$resolve) { if (gethostbyname $name) { $$resolve = $name; } else { $$resolve = $self->default_loopback; warn "lookup $name failed, using $$resolve for client tests\n"; } } join ':', $$resolve, $vars->{port}; } #look for mod_foo.so sub find_apache_module { my($self, $module) = @_; my $vars = $self->{vars}; my $sroot = $vars->{serverroot}; my @trys = grep { $_ } ($vars->{src_dir}, $self->apxs('LIBEXECDIR'), catfile($sroot, 'modules'), catfile($sroot, 'libexec')); for (@trys) { my $file = catfile $_, $module; if (-e $file) { $self->trace("found $module => $file"); return $file; } } } #generate files and directories sub genfile { my($self, $file) = @_; my $name = abs2rel $file, $self->{vars}->{t_dir}; $self->trace("generating $name"); open my $fh, '>', $file or die "open $file: $!"; $self->{clean}->{files}->{$file} = 1; return $fh; } sub gendir { my($self, $dir) = @_; mkdir $dir, 0755 unless -d $dir; $self->{clean}->{dirs}->{$dir} = 1; } sub clean { my $self = shift; for (keys %{ $self->{clean}->{files} }) { if (-e $_) { $self->trace("unlink $_"); unlink $_; } else { #print "unlink $_: $!\n"; } } for (keys %{ $self->{clean}->{dirs} }) { if (-d $_) { opendir(my $dh, $_); my $notempty = grep { ! /^\.{1,2}$/ } readdir $dh; closedir $dh; next if $notempty; $self->trace("rmdir $_"); rmdir $_; } } $self->new_test_server->clean; } sub replace { my $self = shift; s/@(\w+)@/$self->{vars}->{lc $1}/g; } sub replace_vars { my($self, $in, $out) = @_; local $_; while (<$in>) { $self->replace; print $out $_; } } sub index_html_template { my $self = shift; return "welcome to $self->{server}->{name}\n"; } sub generate_index_html { my $self = shift; my $dir = $self->{vars}->{documentroot}; $self->gendir($dir); my $file = catfile $dir, 'index.html'; return if -e $file; my $fh = $self->genfile($file); print $fh $self->index_html_template; } sub types_config_template { "text/html html htm\n"; } sub generate_types_config { my $self = shift; unless ($self->{inherit_config}->{TypesConfig}) { my $types = catfile $self->{vars}->{t_conf}, 'mime.types'; unless (-e $types) { my $fh = $self->genfile($types); print $fh $self->types_config_template; close $fh; } $self->postamble(TypesConfig => qq("$types")); } } sub httpd_conf_template { my($self, $try) = @_; if (open my $in, $try) { return $in; } else { return \*DATA; } } sub generate_extra_conf { my $self = shift; my $extra_conf = catfile $self->{vars}->{t_conf}, 'extra.conf'; return $extra_conf if -e $extra_conf; my $extra_conf_in = join '.', $extra_conf, 'in'; open(my $in, $extra_conf_in) or return; my $out = $self->genfile($extra_conf); $self->replace_vars($in, $out); close $in; close $out; return $extra_conf; } sub generate_httpd_conf { my $self = shift; #generated httpd.conf depends on these things to exist $self->generate_types_config; $self->generate_index_html; for (qw(t_logs t_conf)) { $self->gendir($self->{vars}->{$_}); } if (my $extra_conf = $self->generate_extra_conf) { $self->postamble(Include => qq("$extra_conf")); } my $conf_file = $self->{vars}->{t_conf_file}; my $conf_file_in = join '.', $conf_file, 'in'; my $in = $self->httpd_conf_template($conf_file_in); my $out = $self->genfile($conf_file); $self->preamble_run($out); $self->replace_vars($in, $out); print $out "\n"; $self->postamble_run($out); close $in; close $out or die "close $conf_file: $!"; } #shortcuts my %include_headers = (GET => 1, HEAD => 2); sub http_raw_get { my($self, $url, $h) = @_; $url = "/$url" unless $url =~ m:^/:; my $ih = exists $include_headers{$h ||= 0} ? $include_headers{$h} : $h; require Apache::TestRequest; Apache::TestRequest::http_raw_get($self->{hostport}, $url, $ih); } sub error_log { my($self, $rel) = @_; my $file = catfile $self->{vars}->{t_logs}, 'error_log'; return $file unless $rel; return abs2rel $file, $self->{vars}->{top_dir}; } #utils sub trace { my $self = shift; return unless $self->{verbose}; print "@_\n"; } #duplicating small bits of Apache::Build so we dont require it sub which { foreach (map { catfile $_, $_[0] } File::Spec->path) { return $_ if -x; } } sub apxs { my($self, $q) = @_; return unless $self->{MP_APXS}; my $val = qx($self->{MP_APXS} -q $q 2>/dev/null); warn "APXS ($self->{MP_APXS}) query for $q failed\n" unless $val; $val; } sub pop_dir { my $dir = shift; my @chunks = splitdir $dir; while (my $remove = shift) { pop @chunks if $chunks[-1] eq $remove; } catfile @chunks; } sub add_inc { my $self = shift; require lib; lib::->import(map "$self->{vars}->{top_dir}/$_", qw(lib blib/lib blib/arch)); #print join "\n", @INC, ""; } #freeze/thaw so other processes can access config sub thaw { my $class = shift; $class->new({thaw => 1, @_}); } sub freeze { require Data::Dumper; local $Data::Dumper::Terse = 1; my $data = Data::Dumper::Dumper(shift); chomp $data; $data; } sub save { my($self) = @_; return unless $self->{save}; my $name = 'apache_test_config'; my $file = catfile $self->{vars}->{t_conf}, "$name.pm"; my $fh = $self->genfile($file); $self->trace("saving config data to $name.pm"); (my $obj = $self->freeze) =~ s/^/ /; print $fh <<EOF; package $name; sub new { $obj; } 1; EOF close $fh or die "failed to write $file: $!"; } 1; __DATA__ ServerRoot "@ServerRoot@" DocumentRoot "@DocumentRoot@" Listen @Port@ Group @Group@ User @User@ ServerName @ServerName@ PidFile @t_logs@/httpd.pid ErrorLog @t_logs@/error_log LogLevel debug TransferLog @t_logs@/access_log ServerAdmin @ServerAdmin@ KeepAlive Off HostnameLookups Off <Directory /> Options FollowSymLinks AllowOverride None </Directory> <IfModule threaded.c> StartServers 1 MaxClients 1 MinSpareThreads 1 MaxSpareThreads 1 ThreadsPerChild 1 MaxRequestsPerChild 0 </IfModule> <IfModule prefork.c> StartServers 1 MaxClients 1 MaxRequestsPerChild 0 </IfModule> <Location /server-info> SetHandler server-info </Location> <Location /server-status> SetHandler server-status </Location>