← Back to branch summary

~ubuntu-branches/ubuntu/edgy/libapache2-mod-perl2/edgy

« back to all changes in this revision

Viewing changes to t/response/TestAPI/server_util.pm

  • Committer: Bazaar Package Importer
  • Author(s): Andres Salomon
  • Date: 2005-08-12 01:40:38 UTC
  • mfrom: (1.1.2 upstream) (2.1.1 sarge)
  • Revision ID: james.westby@ubuntu.com-20050812014038-gjigefs55pqx4qc8
Tags: 2.0.1-3
Grr.  Really include perl.conf file; it got lost due to diff not
wanting to add an empty file.

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/response/TestAPI/server_util.pm
7
7
use Apache::TestUtil;
8
8
use File::Spec::Functions qw(canonpath catfile);
9
9
 
10
 
use Apache::RequestRec ();
11
 
use Apache::ServerUtil ();
12
 
use Apache::Process ();
 
10
use Apache2::RequestRec ();
 
11
use Apache2::ServerRec ();
 
12
use Apache2::ServerUtil ();
 
13
use Apache2::Process ();
13
14
 
14
15
use APR::Pool ();
15
16
 
16
 
use Apache::Const -compile => 'OK';
 
17
use Apache2::Const -compile => 'OK';
17
18
 
18
19
my $serverroot = Apache::Test::config()->{vars}->{serverroot};
19
20
 
20
 
our @ISA = qw(Apache::RequestRec);
 
21
our @ISA = qw(Apache2::RequestRec);
21
22
 
22
23
sub new {
23
24
    my $class = shift;
26
27
}
27
28
 
28
29
sub handler {
29
 
 
30
 
    my $r = shift;
31
 
 
32
 
    my %pools = ( 
33
 
        '$r->pool'                       => $r->pool, 
34
 
        '$r->connection->pool'           => $r->connection->pool,
35
 
        '$r->server->process->pool'      => $r->server->process->pool,
36
 
        '$r->server->process->pconf'     => $r->server->process->pconf,
37
 
        'Apache->server->process->pconf' => Apache->server->process->pconf,
38
 
        'APR::Pool->new'                 => APR::Pool->new,
39
 
    );
40
 
 
41
 
    my %objects = ( 
42
 
        '$r'                   => $r,
43
 
        '$r->connection'       => $r->connection,
44
 
        '$r->server'           => $r->server,
45
 
        '__PACKAGE__->new($r)' => __PACKAGE__->new($r),
46
 
    );
47
 
 
48
 
    my %status_lines = (
49
 
       200 => '200 OK',
50
 
       400 => '400 Bad Request',
51
 
       500 => '500 Internal Server Error',
52
 
    );
53
 
    plan $r, tests => (scalar keys %pools) +
54
 
                      (scalar keys %objects) + 
55
 
                      (scalar keys %status_lines) + 11;
 
30
    my $r = shift;
 
31
 
 
32
    plan $r, tests => 17;
 
33
 
 
34
    {
 
35
        my $s = $r->server;
 
36
        my @expected = qw(ModPerl::Test::exit_handler TestExit::FromPerlModule::exit_handler);
 
37
        my @handlers =
 
38
            @{ $s->get_handlers('PerlChildExitHandler') || []};
 
39
        ok t_cmp(scalar(@handlers), scalar(@expected), "get_handlers");
 
40
    }
 
41
 
 
42
    t_debug('Apache2::ServerUtil::exists_config_define');
 
43
    ok Apache2::ServerUtil::exists_config_define('MODPERL2');
 
44
    ok ! Apache2::ServerUtil::exists_config_define('FOO');
 
45
 
 
46
    t_debug('registering method FOO');
 
47
    ok $r->server->method_register('FOO');
 
48
 
 
49
    server_root_relative_tests($r);
 
50
 
 
51
    eval { Apache2::ServerUtil::server_shutdown_cleanup_register(
 
52
        sub { Apache2::Const::OK });
 
53
       };
 
54
    my $sub = "server_shutdown_cleanup_register";
 
55
    ok t_cmp $@, qr/Can't run '$sub' after server startup/,
 
56
        "can't register server_shutdown cleanup after server startup";
 
57
 
 
58
    # on start we get 1, and immediate restart gives 2
 
59
    ok t_cmp Apache2::ServerUtil::restart_count, 2, "restart count";
 
60
 
 
61
    Apache2::Const::OK;
 
62
}
 
63
 
 
64
 
 
65
# 11 sub-tests
 
66
sub server_root_relative_tests {
 
67
    my $r = shift;
 
68
 
 
69
    my %pools = (
 
70
        '$r->pool'                                    =>
 
71
            $r->pool,
 
72
        '$r->connection->pool'                        =>
 
73
            $r->connection->pool,
 
74
        '$r->server->process->pool'                   =>
 
75
            $r->server->process->pool,
 
76
        '$r->server->process->pconf'                  =>
 
77
            $r->server->process->pconf,
 
78
        'Apache2::ServerUtil->server->process->pconf' =>
 
79
            Apache2::ServerUtil->server->process->pconf,
 
80
        'APR::Pool->new'                              =>
 
81
            APR::Pool->new,
 
82
    );
56
83
 
57
84
    # syntax - an object or pool is required
58
 
    t_debug("Apache::server_root_relative() died");
59
 
    eval { my $dir = Apache::server_root_relative() };
 
85
    t_debug("Apache2::ServerUtil::server_root_relative() died");
 
86
    eval { my $dir = Apache2::ServerUtil::server_root_relative() };
60
87
    t_debug("\$\@: $@");
61
88
    ok $@;
62
89
 
63
 
    t_debug("Apache->server_root_relative() died");
64
 
    eval { my $dir = Apache->server_root_relative() };
65
 
    ok $@;
66
 
 
67
 
    # syntax - first argument must be an object, not a class
68
 
    t_debug("Apache->server_root_relative('conf') died");
69
 
    eval { my $dir = Apache->server_root_relative('conf') };
70
 
    ok $@;
71
 
 
72
90
    foreach my $p (keys %pools) {
73
 
 
74
 
        ok t_cmp(catfile($serverroot, 'conf'),
75
 
                 canonpath(Apache::server_root_relative($pools{$p},
76
 
                     'conf')),
77
 
                 "Apache:::server_root_relative($p, 'conf')");
78
 
    }
79
 
 
80
 
    # dig out the pool from valid objects
81
 
    foreach my $obj (keys %objects) {
82
 
 
83
 
        ok t_cmp(catfile($serverroot, 'conf'),
84
 
                 canonpath($objects{$obj}->server_root_relative('conf')),
85
 
                 "$obj->server_root_relative('conf')");
 
91
        # we will leak memory here when calling the function with a
 
92
        # pool whose life is longer than of $r, but it doesn't matter
 
93
        # for the test
 
94
        ok t_filepath_cmp(
 
95
            canonpath(Apache2::ServerUtil::server_root_relative($pools{$p},
 
96
                                                               'conf')),
 
97
            catfile($serverroot, 'conf'),
 
98
            "Apache2::ServerUtil:::server_root_relative($p, 'conf')");
86
99
    }
87
100
 
88
101
    # syntax - unrecognized objects don't segfault
89
102
    {
90
 
        my $obj = bless {}, 'Apache::Foo';
91
 
        eval { Apache::server_root_relative($obj, 'conf') };
 
103
        my $obj = bless {}, 'Apache2::Foo';
 
104
        eval { Apache2::ServerUtil::server_root_relative($obj, 'conf') };
92
105
 
93
 
        ok t_cmp(qr/server_root_relative.*no .* key/,
94
 
                 $@,
95
 
                 "Apache::server_root_relative(\$obj, 'conf')");
 
106
        ok t_cmp($@,
 
107
                 qr/p is not of type APR::Pool/,
 
108
                 "Apache2::ServerUtil::server_root_relative(\$obj, 'conf')");
96
109
    }
97
110
 
98
111
    # no file argument gives ServerRoot
99
 
    ok t_cmp(canonpath($serverroot),
100
 
             canonpath($r->server_root_relative),
101
 
             '$r->server_root_relative()');
102
 
 
103
 
    ok t_cmp(canonpath($serverroot),
104
 
             canonpath(Apache::server_root_relative($r->pool)),
105
 
             'Apache::server_root_relative($r->pool)');
106
 
 
107
 
    # Apache::server_root is also the ServerRoot constant
108
 
    ok t_cmp(canonpath(Apache::server_root),
109
 
             canonpath($r->server_root_relative),
110
 
             'Apache::server_root');
 
112
    {
 
113
        my $server_root_relative = 
 
114
            Apache2::ServerUtil::server_root_relative($r->pool);
 
115
 
 
116
        ok t_filepath_cmp(canonpath($server_root_relative),
 
117
                          canonpath($serverroot),
 
118
                          'server_root_relative($pool)');
 
119
 
 
120
        # Apache2::ServerUtil::server_root is also the ServerRoot constant
 
121
        ok t_filepath_cmp(canonpath(Apache2::ServerUtil::server_root),
 
122
                          canonpath($server_root_relative),
 
123
                          'Apache2::ServerUtil::server_root');
 
124
 
 
125
    }
111
126
 
112
127
    {
113
128
        # absolute paths should resolve to themselves
114
 
        my $dir = $r->server_root_relative('logs');
115
 
 
116
 
        ok t_cmp($r->server_root_relative($dir),
117
 
                 $dir,
118
 
                 "\$r->server_root_relative($dir)");
119
 
    }
120
 
 
121
 
    t_debug('registering method FOO');
122
 
    ok Apache::method_register($r->server->process->pconf, 'FOO');
123
 
 
124
 
    t_debug('Apache::exists_config_define');
125
 
    ok Apache::exists_config_define('MODPERL2');
126
 
    ok ! Apache::exists_config_define('FOO');
127
 
 
128
 
    while (my($code, $line) = each %status_lines) {
129
 
        ok t_cmp($line,
130
 
                 Apache::get_status_line($code),
131
 
                 "Apache::get_status_line($code)");
132
 
    }
133
 
 
134
 
    Apache::OK;
 
129
        my $dir1 = Apache2::ServerUtil::server_root_relative($r->pool, 'logs');
 
130
        my $dir2 = Apache2::ServerUtil::server_root_relative($r->pool, $dir1);
 
131
 
 
132
        ok t_filepath_cmp($dir1, $dir2, "absolute path");
 
133
    }
135
134
}
136
135
 
137
136
1;