diff options
Diffstat (limited to 'debian/perl-framework/t/apache/expr_string.t')
| -rw-r--r-- | debian/perl-framework/t/apache/expr_string.t | 123 |
1 files changed, 123 insertions, 0 deletions
diff --git a/debian/perl-framework/t/apache/expr_string.t b/debian/perl-framework/t/apache/expr_string.t new file mode 100644 index 0000000..4682d4a --- /dev/null +++ b/debian/perl-framework/t/apache/expr_string.t @@ -0,0 +1,123 @@ +use strict; +use warnings FATAL => 'all'; + +use Apache::Test; +use Apache::TestRequest; +use Apache::TestUtil qw(t_write_file t_start_error_log_watch t_finish_error_log_watch t_cmp); + +use File::Spec; + +use Time::HiRes qw(usleep); + +# test ap_expr + +Apache::TestRequest::user_agent(keep_alive => 1); + +# The left-hand values are written into the config file as-is, i.e. +# necessary quoting for the config file parser needs to be included +# explicitly. +my @test_cases = ( + [ 'foo' => 'foo' ], + [ '%{req:SomeHeader}' => 'SomeValue' ], + [ '%{' => undef ], + [ '%' => '%' ], + [ '}' => '}' ], + [ q{\"} => q{"} ], + [ q{\'} => q{'} ], + [ q{"\%{req:SomeHeader}"} => '%{req:SomeHeader}' ], + [ '%{tolower:IDENT}' => 'ident' ], + [ '%{tolower:%{REQUEST_METHOD}}' => 'get' ], +); + +if (have_min_apache_version("2.5")) { + my $SAN_one = "email:<redacted1>, email:<redacted2>, " . + "IP Address:127.0.0.1, IP Address:0:0:0:0:0:0:0:1, " . + "IP Address:192.168.169.170"; + my $SAN_tuple = "'email:<redacted1>', 'email:<redacted2>', " . + "'IP Address:127.0.0.1', 'IP Address:0:0:0:0:0:0:0:1', " . + "'IP Address:192.168.169.170'"; + my $SAN_list_one = "{ '$SAN_one' }"; + my $SAN_list_tuple = "{ $SAN_tuple }"; + + push(@test_cases, ( + [ qq["%{tolower:%{:toupper(%{REQUEST_METHOD}):}}"] => "get" ], + [ qq["%{: join $SAN_list_one :}"] => "$SAN_one" ], + [ qq["%{: join($SAN_list_tuple, ', ') :}"] => "$SAN_one" ], + [ qq['%{tolower:"IDENT"}'] => '"ident"' ], + [ qq["%{: 'IP Address:%{REMOTE_ADDR}' -in split/, /, join $SAN_list_one :}"] + => "true" ], + )); +} + +my $successful_expected = scalar(grep { defined $_->[1] } @test_cases); + +plan tests => scalar(@test_cases) * 2 + $successful_expected, + need need_lwp, + need_module('mod_log_debug'); +foreach my $t (@test_cases) { + my ($expr, $expect) = @{$t}; + + write_htaccess($expr); + + t_start_error_log_watch(); + my $response = GET('/apache/expr/index.html', + 'SomeHeader' => 'SomeValue', + 'User-Agent' => 'SomeAgent', + 'Referer' => 'SomeReferer'); + ### Sleep here, attempt to avoid intermittent failures. + usleep(250000); + my @loglines = t_finish_error_log_watch(); + + my @evalerrors = grep {/(?:internal evaluation error|flex scanner jammed)/i + } @loglines; + my $num_errors = scalar @evalerrors; + print "Error log should not have 'Internal evaluation error' or " . + "'flex scanner jammed' entries, found $num_errors:\n@evalerrors\n" + if $num_errors; + ok($num_errors == 0); + + my $rc = $response->code; + + if (!defined $expect) { + print qq{Should get parse error (500) for "$expr", got $rc\n}; + ok($rc == 500); + } + else { + print qq{Expected return code 200, got $rc for '$expr'\n}; + ok($rc == 200); + my @msg = grep { /log_debug:info/ } @loglines; + if (scalar @msg != 1) { + print "expected 1 message, got " . scalar @msg . ":\n@msg\n"; + ok(0); + } + elsif ($msg[0] =~ m{^(?:\[ # opening '[' + [^\]]+ # anything but a ']' + \] # closing ']' + [ ] # trailing space + ){4} # repeat 4 times (timestamp, level, pid, client IP) + (.*?) # The actual message logged by LogMessage + (,[ ]referer # either trailing referer (LogLevel info) + | # or + [ ]\(log_transaction) # trailing hook info (LogLevel debug and higher) + }x ) { + my $result = $1; + ok t_cmp($result, $expect, "log message @msg didn't match"); + } + else { + print "Can't extract expr result from log message:\n@msg\n"; + ok(0); + } + } +} + +exit 0; + +### sub routines +sub write_htaccess +{ + my $expr = shift; + my $file = File::Spec->catfile(Apache::Test::vars('serverroot'), 'htdocs', 'apache', 'expr', '.htaccess'); + t_write_file($file, << "EOF" ); +LogMessage $expr +EOF +} |