File Coverage

blib/lib/Apache/TestUtil.pm
Criterion Covered Total %
statement 78 202 38.6
branch 12 88 13.6
condition 3 21 14.3
subroutine 21 42 50.0
pod 20 25 80.0
total 134 378 35.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::TestUtil;
17              
18 2     2   27 use strict;
  2         20  
  2         38  
19 2     2   31 use warnings FATAL => 'all';
  2         23  
  2         37  
20              
21 2     2   29 use File::Find ();
  2         54  
  2         55  
22 2     2   29 use File::Path ();
  2         18  
  2         19  
23 2     2   43 use Exporter ();
  2         30  
  2         18  
24 2     2   28 use Carp ();
  2         17  
  2         19  
25 2     2   27 use Config;
  2         18  
  2         34  
26 2     2   30 use File::Basename qw(dirname);
  2         17  
  2         43  
27 2     2   30 use File::Spec::Functions qw(catfile file_name_is_absolute);
  2         18  
  2         38  
28 2     2   35 use Symbol ();
  2         18  
  2         18  
29 2     2   28 use Fcntl qw(SEEK_END);
  2         18  
  2         40  
30              
31 2     2   30 use Apache::Test ();
  2         20  
  2         27  
32 2     2   30 use Apache::TestConfig ();
  2         18  
  2         21  
33              
34 2     2   28 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %CLEAN);
  2         19  
  2         35  
35              
36             $VERSION = '0.02';
37             @ISA     = qw(Exporter);
38              
39             @EXPORT = qw(t_cmp t_debug t_append_file t_write_file t_open_file
40             t_mkdir t_rmtree t_is_equal t_filepath_cmp
41             t_server_log_error_is_expected t_server_log_warn_is_expected
42             t_client_log_error_is_expected t_client_log_warn_is_expected
43             );
44              
45             @EXPORT_OK = qw(t_write_perl_script t_write_shell_script t_chown
46             t_catfile_apache t_catfile
47             t_start_error_log_watch t_finish_error_log_watch);
48              
49             %CLEAN = ();
50              
51             $Apache::TestUtil::DEBUG_OUTPUT = \*STDOUT;
52              
53             # 5.005's Data::Dumper has problems to dump certain datastructures
54 2 50   2   42 use constant HAS_DUMPER => eval { $] >= 5.6 && require Data::Dumper; };
  2         20  
  2         22  
  2         55  
55 2     2   32 use constant INDENT => 4;
  2         18  
  2         26  
56              
57             {
58                 my $f;
59                 sub t_start_error_log_watch {
60              
61 0     0 1 0         my $name = File::Spec->catfile(Apache::Test::vars->{t_logs}, 'error_log');
62 0 0       0         open $f, "$name" or die "ERROR: Cannot open $name: $!\n";
63 0         0         seek $f, 0, SEEK_END;
64              
65 0         0         return;
66                 }
67              
68                 sub t_finish_error_log_watch {
69              
70 0     0 1 0         local $/ = "\n";
71 0         0         my @lines = <$f>;
72 0         0         undef $f;
73              
74 0         0         return @lines;
75                 }
76             }
77              
78             # because of the prototype and recursive call to itself a forward
79             # declaration is needed
80             sub t_is_equal ($$);
81              
82             # compare any two datastructures (must pass references for non-scalars)
83             # undef()'s are valid args
84             sub t_is_equal ($$) {
85 2     2 1 22     my ($a, $b) = @_;
86 2 50       25     return 0 unless @_ == 2;
87              
88             # this was added in Apache::Test::VERSION 1.12 - remove deprecated
89             # logic sometime around 1.15 or mid September, 2004.
90 2 50       31     if (UNIVERSAL::isa($a, 'Regexp')) {
91 0         0         my @warning = ("WARNING!!! t_is_equal() argument order has changed.",
92                                    "use of a regular expression as the first argument",
93                                    "is deprecated. support will be removed soon.");
94 0         0         t_debug(@warning);
95 0         0         ($a, $b) = ($b, $a);
96                 }
97              
98 2 50 33     44     if (defined $a && defined $b) {
99 2         20         my $ref_a = ref $a;
100 2         19         my $ref_b = ref $b;
101 2 50 33     30         if (!$ref_a && !$ref_b) {
    0 0        
    0 0        
    0          
102 2         64             return $a eq $b;
103                     }
104                     elsif ($ref_a eq 'ARRAY' && $ref_b eq 'ARRAY') {
105 0 0       0             return 0 unless @$a == @$b;
106 0         0             for my $i (0..$#$a) {
107 0 0       0                 t_is_equal($a->[$i], $b->[$i]) || return 0;
108                         }
109                     }
110                     elsif ($ref_a eq 'HASH' && $ref_b eq 'HASH') {
111 0 0       0             return 0 unless (keys %$a) == (keys %$b);
112 0         0             for my $key (sort keys %$a) {
113 0 0       0                 return 0 unless exists $b->{$key};
114 0 0       0                 t_is_equal($a->{$key}, $b->{$key}) || return 0;
115                         }
116                     }
117                     elsif ($ref_b eq 'Regexp') {
118 0         0             return $a =~ $b;
119                     }
120                     else {
121             # try to compare the references
122 0         0             return $a eq $b;
123                     }
124                 }
125                 else {
126             # undef == undef! a valid test
127 0 0 0     0         return (defined $a || defined $b) ? 0 : 1;
128                 }
129 0         0     return 1;
130             }
131              
132              
133              
134             sub t_cmp ($$;$) {
135 2 50 33 2 1 1395     Carp::carp(join(":", (caller)[1..2]) .
136                     ' usage: $res = t_cmp($received, $expected, [$comment])')
137                         if @_ < 2 || @_ > 3;
138              
139 2         22     my ($received, $expected) = @_;
140              
141             # this was added in Apache::Test::VERSION 1.12 - remove deprecated
142             # logic sometime around 1.15 or mid September, 2004.
143 2 50       29     if (UNIVERSAL::isa($_[0], 'Regexp')) {
144 0         0         my @warning = ("WARNING!!! t_cmp() argument order has changed.",
145                                    "use of a regular expression as the first argument",
146                                    "is deprecated. support will be removed soon.");
147 0         0         t_debug(@warning);
148 0         0         ($received, $expected) = ($expected, $received);
149                 }
150              
151 2 50       43     t_debug("testing : " . pop) if @_ == 3;
152 2         64     t_debug("expected: " . struct_as_string(0, $expected));
153 2         23     t_debug("received: " . struct_as_string(0, $received));
154 2         49     return t_is_equal($received, $expected);
155             }
156              
157             # Essentially t_cmp, but on Win32, first converts pathnames
158             # to their DOS long name.
159             sub t_filepath_cmp ($$;$) {
160 0     0 1 0     my @a = (shift, shift);
161 0         0     if (Apache::TestConfig::WIN32) {
162                     $a[0] = Win32::GetLongPathName($a[0]) if defined $a[0];
163                     $a[1] = Win32::GetLongPathName($a[1]) if defined $a[1];
164                 }
165 0 0       0     return @_ == 1 ? t_cmp($a[0], $a[1], $_[0]) : t_cmp($a[0], $a[1]);
166             }
167              
168              
169             *expand = HAS_DUMPER ?
170                 sub { map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_ } :
171 6     6   60     sub { @_ };
172              
173             sub t_debug {
174 6     6 1 51     my $out = $Apache::TestUtil::DEBUG_OUTPUT;
175 6         59     print $out map {"# $_\n"} map {split /\n/} grep {defined} expand(@_);
  6         2526  
  6         63  
  6         59  
176             }
177              
178             sub t_open_file {
179 0     0 1 0     my $file = shift;
180              
181 0 0       0     die "must pass a filename" unless defined $file;
182              
183             # create the parent dir if it doesn't exist yet
184 0         0     makepath(dirname $file);
185              
186 0         0     my $fh = Symbol::gensym();
187 0 0       0     open $fh, ">$file" or die "can't open $file: $!";
188 0         0     t_debug("writing file: $file");
189 0         0     $CLEAN{files}{$file}++;
190              
191 0         0     return $fh;
192             }
193              
194             sub t_write_file {
195 0     0 1 0     my $file = shift;
196              
197 0 0       0     die "must pass a filename" unless defined $file;
198              
199             # create the parent dir if it doesn't exist yet
200 0         0     makepath(dirname $file);
201              
202 0         0     my $fh = Symbol::gensym();
203 0 0       0     open $fh, ">$file" or die "can't open $file: $!";
204 0         0     t_debug("writing file: $file");
205 0 0       0     print $fh join '', @_ if @_;
206 0         0     close $fh;
207 0         0     $CLEAN{files}{$file}++;
208             }
209              
210             sub t_append_file {
211 0     0 1 0     my $file = shift;
212              
213 0 0       0     die "must pass a filename" unless defined $file;
214              
215             # create the parent dir if it doesn't exist yet
216 0         0     makepath(dirname $file);
217              
218             # add to the cleanup list only if we created it now
219 0 0       0     $CLEAN{files}{$file}++ unless -e $file;
220              
221 0         0     my $fh = Symbol::gensym();
222 0 0       0     open $fh, ">>$file" or die "can't open $file: $!";
223 0 0       0     print $fh join '', @_ if @_;
224 0         0     close $fh;
225             }
226              
227             sub t_write_shell_script {
228 0     0 1 0     my $file = shift;
229              
230 0         0     my $code = join '', @_;
231 0         0     my($ext, $shebang);
232              
233 0         0     if (Apache::TestConfig::WIN32()) {
234                     $code =~ s/echo$/echo./mg; #required to echo newline
235                     $ext = 'bat';
236                     $shebang = "\@echo off\nREM this is a bat";
237                 }
238                 else {
239 0         0         $ext = 'sh';
240 0         0         $shebang = '#!/bin/sh';
241                 }
242              
243 0         0     $file .= ".$ext";
244 0         0     t_write_file($file, "$shebang\n", $code);
245 0         0     $ext;
246             }
247              
248             sub t_write_perl_script {
249 0     0 1 0     my $file = shift;
250              
251 0         0     my $shebang = "#!$Config{perlpath}\n";
252 0         0     my $warning = Apache::TestConfig->thaw->genwarning($file);
253 0         0     t_write_file($file, $shebang, $warning, @_);
254 0         0     chmod 0755, $file;
255             }
256              
257              
258             sub t_mkdir {
259 0     0 1 0     my $dir = shift;
260 0         0     makepath($dir);
261             }
262              
263             # returns a list of dirs successfully created
264             sub makepath {
265 0     0 0 0     my($path) = @_;
266              
267 0 0 0     0     return if !defined($path) || -e $path;
268 0         0     my $full_path = $path;
269              
270             # remember which dirs were created and should be cleaned up
271 0         0     while (1) {
272 0         0         $CLEAN{dirs}{$path} = 1;
273 0         0         $path = dirname $path;
274 0 0       0         last if -e $path;
275                 }
276              
277 0         0     return File::Path::mkpath($full_path, 0, 0755);
278             }
279              
280             sub t_rmtree {
281 0 0   0 1 0     die "must pass a dirname" unless defined $_[0];
282 0 0       0     File::Path::rmtree((@_ > 1 ? \@_ : $_[0]), 0, 1);
283             }
284              
285             #chown a file or directory to the test User/Group
286             #noop if chown is unsupported
287              
288             sub t_chown {
289 0     0 1 0     my $file = shift;
290 0         0     my $config = Apache::Test::config();
291 0         0     my($uid, $gid);
292              
293 0         0     eval {
294             #XXX cache this lookup
295 0         0         ($uid, $gid) = (getpwnam($config->{vars}->{user}))[2,3];
296                 };
297              
298 0 0       0     if ($@) {
299 0 0       0         if ($@ =~ /^The getpwnam function is unimplemented/) {
300             #ok if unsupported, e.g. win32
301 0         0             return 1;
302                     }
303                     else {
304 0         0             die $@;
305                     }
306                 }
307              
308 0 0       0     CORE::chown($uid, $gid, $file) || die "chown $file: $!";
309             }
310              
311             # $string = s