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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
package Lemonldap::NG::Handler::API::ApacheMP1;
our $VERSION = '1.9.1';
# Specific modules and constants for Apache Mod_Perl 1
use Apache;
use Apache::Log;
use Apache::Constants qw(:common :response);
## @method void setServerSignature(string sign)
# modifies web server signature
# @param $sign String to add to server signature
sub setServerSignature {
my ( $class, $sign ) = @_;
#TODO
}
## @method void thread_share(string $variable)
# share or not the variable (if authorized by specific module)
# @param $variable the name of the variable to share
sub thread_share {
my ( $class, $variable ) = @_;
# nothing to do in ApacheMP1
}
## @method void lmLog(string $msg, string $level, Apache::RequestRec $r)
# logs message $msg to Apache logs with loglevel $level
# @param $msg string message to log
# @param $level string loglevel
# @param $r Apache2::RequestRec optional Current request
sub lmLog {
my ( $class, $msg, $level, $r ) = @_;
Apache->server->log->$level($msg);
}
## @method void set_user(Apache2::RequestRec request, string user)
# sets remote_user
# @param request Apache2::RequestRec current request
# @param user string username
sub set_user {
my ( $class, $r, $user ) = @_;
$r->connection->user($user);
}
## @method string header_in(Apache2::RequestRec request, string header)
# returns request header value
# @param request Apache2::RequestRec current request
# @param header string request header
# @return request header value
sub header_in {
my ( $class, $r, $header ) = @_;
return $r->header_in($header);
}
## @method void set_header_in(Apache2::RequestRec request, hash headers)
# sets or modifies request headers
# @param request Apache2::RequestRec current request
# @param headers hash containing header names => header value
sub set_header_in {
my ( $class, $r, %headers ) = @_;
while ( my ( $h, $v ) = each %headers ) {
$r->header_in( $h => $v );
}
}
## @method void unset_header_in(Apache2::RequestRec request, array headers)
# removes request headers
# @param request Apache2::RequestRec current request
# @param headers array with header names to remove
sub unset_header_in {
my ( $class, $r, @headers ) = @_;
foreach my $h (@headers) {
$r->header_in( $h => "" ) if ( $r->header_in($h) );
}
}
## @method void set_header_out(Apache2::RequestRec request, hash headers)
# sets response headers
# @param request Apache2::RequestRec current request
# @param headers hash containing header names => header value
sub set_header_out {
my ( $class, $r, %headers ) = @_;
while ( my ( $h, $v ) = each %headers ) {
$r->err_header_out( $h => $v );
}
}
## @method string hostname(Apache2::RequestRec request)
# returns host, as set by full URI or Host header
# @param request Apache2::RequestRec current request
# @return host string Host value
sub hostname {
my ( $class, $r ) = @_;
return $r->hostname;
}
## @method string remote_ip(Apache2::RequestRec request)
# returns client IP address
# @param request Apache2::RequestRec current request
# @return IP_Addr string client IP
sub remote_ip {
my ( $class, $r ) = @_;
return $r->remote_ip;
}
## @method boolean is_initial_req(Apache2::RequestRec request)
# always returns true, since Apache mod_perl 1 has no such feature
# @param request Apache2::RequestRec current request
# @return is_initial_req boolean
sub is_initial_req {
my ( $class, $r ) = @_;
return 1;
}
## @method string args(Apache2::RequestRec request, string args)
# gets the query string
# @param request Apache2::RequestRec current request
# @return args string Query string
sub args {
my ( $class, $r ) = @_;
return $r->args();
}
## @method string uri(Apache2::RequestRec request)
# returns the path portion of the URI, normalized, i.e. :
# * URL decoded (characters encoded as %XX are decoded,
# except ? in order not to merge path and query string)
# * references to relative path components "." and ".." are resolved
# * two or more adjacent slashes are merged into a single slash
# @param request Apache2::RequestRec current request
# @return path portion of the URI, normalized
sub uri {
my ( $class, $r ) = @_;
my $uri = $r->uri;
$uri =~ s#//+#/#g;
$uri =~ s#\?#%3F#g;
return $uri;
}
## @method string uri_with_args(Apache2::RequestRec request)
# returns the URI, with arguments and with path portion normalized
# @param request Apache2::RequestRec current request
# @return URI with normalized path portion
sub uri_with_args {
my ( $class, $r ) = @_;
return $class->uri($r) . ( $r->args ? "?" . $r->args : "" );
}
## @method string unparsed_uri(Apache2::RequestRec request)
# returns the full original request URI, with arguments
# @param request Apache2::RequestRec current request
# @return full original request URI, with arguments
sub unparsed_uri {
my ( $class, $r ) = @_;
return $r->unparsed_uri;
}
## @method string get_server_port(Apache2::RequestRec request)
# returns the port the server is receiving the current request on
# @param request Apache2::RequestRec current request
# @return port string server port
sub get_server_port {
my ( $class, $r ) = @_;
return $r->get_server_port;
}
## @method void print(string data, Apache2::RequestRec request)
# write data in HTTP response body
# @param data Text to add in response body
# @param request Apache2::RequestRec Current request
sub print {
my ( $class, $data, $r ) = @_;
$r->print($data);
}
1;
|
