File Coverage

blib/lib/Apache/TestServer.pm
Criterion Covered Total %
statement 65 329 19.8
branch 4 92 4.3
condition 6 46 13.0
subroutine 17 41 41.5
pod 1 26 3.8
total 93 534 17.4


line stmt bran cond sub pod time code
1             # Licensed to the Apache Software Foundation (ASF) under one or more
2             # contributor license agreements. See the NOTICE file distributed with
3             # this work for additional information regarding copyright ownership.
4             # The ASF licenses this file to You under the Apache License, Version 2.0
5             # (the "License"); you may not use this file except in compliance with
6             # the License. You may obtain a copy of the License at
7             #
8             # http://www.apache.org/licenses/LICENSE-2.0
9             #
10             # Unless required by applicable law or agreed to in writing, software
11             # distributed under the License is distributed on an "AS IS" BASIS,
12             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13             # See the License for the specific language governing permissions and
14             # limitations under the License.
15             #
16             package Apache::TestServer;
17              
18 6     6   89 use strict;
  6         59  
  6         105  
19 6     6   92 use warnings FATAL => 'all';
  6         87  
  6         94  
20              
21 6     6   95 use Config;
  6         57  
  6         91  
22 6     6   126 use Socket ();
  6         55  
  6         60  
23 6     6   93 use File::Spec::Functions qw(catfile);
  6         56  
  6         115  
24              
25 6     6   96 use Apache::TestTrace;
  6         54  
  6         95  
26 6     6   1913 use Apache::TestRun;
  6         61  
  6         144  
27 6     6   158 use Apache::TestConfig ();
  6         55  
  6         118  
28 6     6   92 use Apache::TestRequest ();
  6         57  
  6         55  
29              
30 6     6   104 use constant COLOR => Apache::TestConfig::COLOR;
  6         53  
  6         483  
31 6     6   152 use constant WIN32 => Apache::TestConfig::WIN32;
  6         58  
  6         77  
32              
33             my $CTRL_M = COLOR ? "\r" : "\n";
34              
35             # some debuggers use the same syntax as others, so we reuse the same
36             # code by using the following mapping
37             my %debuggers = (
38                 gdb => 'gdb',
39                 ddd => 'gdb',
40                 valgrind => 'valgrind',
41                 strace => 'strace',
42             );
43              
44             sub new {
45 6     6 0 66     my $class = shift;
46 6         56     my $config = shift;
47              
48 6   33     99     my $self = bless {
49                     config => $config || Apache::TestConfig->thaw,
50                 }, $class;
51              
52 12         170     $self->{name} = join ':',
53 6         64       map { $self->{config}->{vars}->{$_} } qw(servername port);
54              
55 6         71     $self->{port_counter} = $self->{config}->{vars}->{port};
56              
57 6         156     $self;
58             }
59              
60             # call this when you already know where httpd is
61             sub post_config {
62 6     6 0 116     my($self) = @_;
63              
64 6   50     235     $self->{version} = $self->{config}->httpd_version || '';
65 6   50     1272     $self->{mpm} = $self->{config}->httpd_mpm || '';
66              
67             # try to get the revision number from the standard Apache version
68             # string and various variations made by distributions which mangle
69             # that string
70              
71             # Foo-Apache-Bar/x.y.z
72 6         500     ($self->{rev}) = $self->{version} =~ m|/(\d)\.|;
73              
74 6 50       184     if ($self->{rev}) {
75 6         1196         debug "Matched Apache revision $self->{version} $self->{rev}";
76                 }
77                 else {
78             # guessing is not good as it'll only mislead users
79             # and we can't die since a config object is required
80             # during Makefile.PL's write_perlscript when path to httpd may
81             # be unknown yet. so default to non-existing version 0 for now.
82             # and let TestRun.pm figure out the required pieces
83 0         0         debug "can't figure out Apache revision, from string: " .
84                         "'$self->{version}', using a non-existing revision 0";
85 0         0         $self->{rev} = 0; # unknown
86                 }
87              
88 6         360     $self;
89             }
90              
91             sub version_of {
92 0     0 0 0     my($self, $thing) = @_;
93 0 0       0     die "Can't figure out what Apache server generation we are running"
94                     unless $self->{rev};
95              
96 0         0     $thing->{$self->{rev}};
97             }
98              
99             my @apache_logs = qw(
100             error_log access_log httpd.pid
101             apache_runtime_status rewrite_log
102             ssl_engine_log ssl_request_log
103             cgisock
104             );
105              
106             sub clean {
107 0     0 0 0     my $self = shift;
108              
109 0         0     my $dir = $self->{config}->{vars}->{t_logs};
110              
111 0         0     for (@apache_logs) {
112 0         0         my $file = catfile $dir, $_;
113 0 0       0         if (unlink $file) {
114 0         0             debug "unlink $file";
115                     }
116                 }
117             }
118              
119             sub pid_file {
120 1     1 0 10     my $self = shift;
121              
122 1         12     my $vars = $self->{config}->{vars};
123              
124 1   33     17     return $vars->{t_pid_file} || catfile $vars->{t_logs}, 'httpd.pid';
125             }
126              
127             sub dversion {
128 0     0 0 0     my $self = shift;
129 0         0     "-D APACHE$self->{rev}";
130             }
131              
132             sub config_defines {
133 0     0 0 0     my $self = shift;
134              
135 0         0     my @defines = ();
136              
137 0         0     for my $item (qw(useithreads)) {
138 0 0 0     0         next unless $Config{$item} and $Config{$item} eq 'define';
139 0         0         push @defines, "-D PERL_\U$item";
140                 }
141              
142 0 0       0     if (my $defines = $self->{config}->{vars}->{defines}) {
143 0         0         push @defines, map { "-D $_" } split " ", $defines;
  0         0  
144                 }
145              
146 0         0     "@defines";
147             }
148              
149             sub args {
150 0     0 0 0     my $self = shift;
151 0         0     my $vars = $self->{config}->{vars};
152 0         0     my $dversion = $self->dversion; #for .conf version conditionals
153 0         0     my $defines = $self->config_defines;
154              
155 0         0     "-d $vars->{serverroot} -f $vars->{t_conf_file} $dversion $defines";
156             }
157              
158             my %one_process = (1 => '-X', 2 => '-D ONE_PROCESS');
159              
160             sub start_cmd {
161 0     0 0 0     my $self = shift;
162              
163 0         0     my $args = $self->args;
164 0         0     my $config = $self->{config};
165 0         0     my $vars = $config->{vars};
166 0         0     my $httpd = $vars->{httpd};
167              
168 0 0       0     my $one_process = $self->{run}->{opts}->{'one-process'}
169                     ? $self->version_of(\%one_process)
170                     : '';
171              
172             #XXX: threaded mpm does not respond to SIGTERM with -D ONE_PROCESS
173              
174 0         0     return "$httpd $one_process $args";
175             }
176              
177             sub default_gdbinit {
178 0     0 0 0     my $gdbinit = "";
179 0         0     my @sigs = qw(PIPE);
180              
181 0         0     for my $sig (@sigs) {
182 0         0         for my $flag (qw(pass nostop)) {
183 0         0             $gdbinit .= "handle SIG$sig $flag\n";
184                     }
185                 }
186              
187 0         0     $gdbinit;
188             }
189              
190             sub strace_cmd {
191 0     0 0 0     my($self, $strace, $file) = @_;
192             #XXX truss, ktrace, etc.
193 0         0     "$strace -f -o $file -s1024";
194             }
195              
196             sub valgrind_cmd {
197 0     0 0 0     my($self, $valgrind) = @_;
198 0         0     "$valgrind -v --leak-check=yes --show-reachable=yes --error-limit=no";
199             }
200              
201             sub start_valgrind {
202 0     0 0 0     my $self = shift;
203 0         0     my $opts = shift;
204              
205 0         0     my $config = $self->{config};
206 0         0     my $args = $self->args;
207 0         0     my $one_process = $self->version_of(\%one_process);
208 0         0     my $valgrind_cmd = $self->valgrind_cmd($opts->{debugger});
209 0         0     my $httpd = $config->{vars}->{httpd};
210              
211 0         0     my $command = "$valgrind_cmd $httpd $one_process $args";
212              
213 0         0     debug $command;
214 0         0     system $command;
215             }
216              
217             sub start_strace {
218 0     0 0 0     my $self = shift;
219 0         0     my $opts = shift;
220              
221 0         0     my $config = $self->{config};
222 0         0     my $args = $self->args;
223 0         0     my $one_process = $self->version_of(\%one_process);
224 0         0     my $file = catfile $config->{vars}->{t_logs}, 'strace.log';
225 0         0     my $strace_cmd = $self->strace_cmd($opts->{debugger}, $file);
226 0         0     my $httpd = $config->{vars}->{httpd};
227              
228 0         0     $config->genfile($file); #just mark for cleanup
229              
230 0         0     my $command = "$strace_cmd $httpd $one_process $args";
231              
232 0         0     debug $command;
233 0         0     system $command;
234             }
235              
236             sub start_gdb {
237 0     0 0 0     my $self = shift;
238 0         0     my $opts = shift;
239              
240 0         0     my $debugger = $opts->{debugger};
241 0 0       0     my @breakpoints = @{ $opts->{breakpoint} || [] };
  0         0  
242 0         0     my $config = $self->{config};
243 0         0     my $args = $self->args;
244 0         0     my $one_process = $self->version_of(\%one_process);
245              
246 0         0     my $file = catfile $config->{vars}->{serverroot}, '.gdb-test-start';
247 0         0     my $fh = $config->genfile($file);
248              
249 0         0     print $fh default_gdbinit();
250              
251 0 0       0     if (@breakpoints) {
252 0         0         print $fh "b ap_run_pre_config\n";
253 0         0         print $fh "run $one_process $args\n";
254 0         0         print $fh "finish\n";
255 0         0         for (@breakpoints) {
256 0         0             print $fh "b $_\n"
257                     }
258 0         0         print $fh "continue\n";
259                 }
260                 else {
261 0         0         print $fh "run $one_process $args\n";
262                 }
263 0         0     close $fh;
264              
265 0         0     my $command;
266 0         0     my $httpd = $config->{vars}->{httpd};
267              
268 0 0       0     if ($debugger eq 'ddd') {
269 0         0         $command = qq{ddd --gdb --debugger "gdb -command $file" $httpd};
270                 }
271                 else {
272             ## defaults to gdb if not set in %ENV or via -debug
273 0         0         $command = "$debugger $httpd -command $file";
274                 }
275              
276 0         0     $self->note_debugging;
277 0         0     debug $command;
278 0         0     system $command;
279              
280 0         0     unlink $file;
281             }
282              
283             sub debugger_file {
284 0     0 0 0     my $self = shift;
285 0         0     catfile $self->{config}->{vars}->{serverroot}, '.debugging';
286             }
287              
288             #make a note that the server is running under the debugger
289             #remove note when this process exits via END
290              
291             sub note_debugging {
292 0     0 0 0     my $self = shift;
293 0         0     my $file = $self->debugger_file;
294 0         0     my $fh = $self->{config}->genfile($file);
295 0         0     eval qq(END { unlink "$file" });
296             }
297              
298             sub start_debugger {
299 0     0 0 0     my $self = shift;
300 0         0     my $opts = shift;
301              
302 0   0     0     $opts->{debugger} ||= $ENV{MP_DEBUGGER} || 'gdb';
      0        
303              
304             # XXX: FreeBSD 5.2+
305             # gdb 6.1 and before segfaults when trying to
306             # debug httpd startup code. 6.5 has been proven
307             # to work. FreeBSD typically installs this as
308             # gdb65.
309             # Is it worth it to check the debugger and os version
310             # and die ?
311              
312 0 0       0     unless (grep { /^$opts->{debugger}/ } keys %debuggers) {
  0         0  
313 0         0         error "$opts->{debugger} is not a supported debugger",
314                           "These are the supported debuggers: ".
315                           join ", ", sort keys %debuggers;
316 0         0         die("\n");
317                 }
318              
319 0         0     my $debugger = $opts->{debugger};
320 0         0     $debugger =~ s/\d+$//;
321              
322 0         0     my $method = "start_" . $debuggers{$debugger};
323              
324             ## $opts->{debugger} is passed through unchanged
325             ## so when we try to run it next, its found.
326 0         0     $self->$method($opts);
327             }
328              
329             sub pid {
330 1     1 0 12     my $self = shift;
331 1   <