File: perlloadmodule.pm

package info (click to toggle)
libapache2-mod-perl2 2.0.13-2
  • links: PTS, VCS
  • area: main
  • in suites: sid, trixie
  • size: 12,016 kB
  • sloc: perl: 97,771; ansic: 14,493; makefile: 51; sh: 18
file content (152 lines) | stat: -rw-r--r-- 3,181 bytes parent folder | download | duplicates (7)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
package TestDirective::perlloadmodule;

use strict;
use warnings FATAL => 'all';

use Apache::Test;
use Apache::TestUtil;
use Apache::TestTrace;

use Apache2::Const -compile => qw(OK OR_ALL RSRC_CONF TAKE1 TAKE23);

use Apache2::CmdParms ();
use Apache2::Module ();

my @directives = (
    {
     name => 'MyTest',
     func => __PACKAGE__ . '::MyTest',
     req_override => Apache2::Const::RSRC_CONF,
#     req_override => 'RSRC_CONF', #test 1.x compat for strings
#     args_how => Apache2::Const::TAKE23,
     args_how => 'TAKE23', #test 1.x compat for strings
     errmsg => 'A test',
    },
    {
     name => 'MyOtherTest',
     cmd_data => 'some info',
    },
    {
     name => 'ServerTest',
     req_override => Apache2::Const::RSRC_CONF,
    }
);

Apache2::Module::add(__PACKAGE__, \@directives);

sub DIR_CREATE {
    my ($class, $parms) = @_;

    bless {
        path => $parms->path || "/",
    }, $class;
}

sub merge {
    my ($base, $add) = @_;

    my %new = ();

    @new{keys %$base, keys %$add} =
        (values %$base, values %$add);

    return bless \%new, ref($base);
}

sub DIR_MERGE {
    my $class = ref $_[0];
    debug "$class->DIR_MERGE\n";
    merge(@_);
}

#sub SERVER_MERGE {
#    my $class = ref $_[0];
#    debug "$class->SERVER_MERGE\n";
#    merge(@_);
#}

sub SERVER_CREATE {
    my ($class, $parms) = @_;
    debug "$class->SERVER_CREATE\n";
    return bless {
        name => __PACKAGE__,
    }, $class;
}

sub MyTest {
    my ($self, $parms, @args) = @_;
    $self->{MyTest} = \@args;
    $self->{MyTestInfo} = $parms->info;
}

sub MyOtherTest {
    my ($self, $parms, $arg) = @_;
    $self->{MyOtherTest} = $arg;
    $self->{MyOtherTestInfo} = $parms->info;
}

sub ServerTest {
    my ($self, $parms, $arg) = @_;
    my $srv_cfg = $self->get_config($parms->server);
    $srv_cfg->{ServerTest} = $arg;
}

sub get_config {
    my ($self, $s) = (shift, shift);
    Apache2::Module::get_config($self, $s, @_);
}

sub handler : method {
    my ($self, $r) = @_;

    my $s = $r->server;
    my $dir_cfg = $self->get_config($s, $r->per_dir_config);
    my $srv_cfg = $self->get_config($s);

    plan $r, tests => 9;

    t_debug("per-dir config:", $dir_cfg);
    t_debug("per-srv config:", $srv_cfg);

    ok $dir_cfg->isa($self);
    ok $srv_cfg->isa($self);

    my $path = $dir_cfg->{path};

    ok t_cmp($r->uri, qr{^$path},
             'r->uri =~ parms->path');

    ok t_cmp($srv_cfg->{name}, $self,
             '$self eq $srv_cfg->{name}');

    ok t_cmp($dir_cfg->{MyOtherTest}, 'value',
             'MyOtherTest value');

    ok t_cmp($dir_cfg->{MyOtherTestInfo}, 'some info',
             'MyOtherTest cmd_data');

    ok t_cmp($dir_cfg->{MyTest}, ['one', 'two'],
             'MyTest one two');

    ok ! $dir_cfg->{MyTestInfo};

    ok t_cmp($srv_cfg->{ServerTest}, 'per-server');

    Apache2::Const::OK;
}

1;
__END__

# APACHE_TEST_CONFIG_ORDER 950

<Base>
    PerlLoadModule TestDirective::perlloadmodule

    MyTest one two
    ServerTest per-server
</Base>

MyOtherTest value