File: PSGI.pm

package info (click to toggle)
lemonldap-ng 1.9.7-3%2Bdeb9u2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 39,024 kB
  • sloc: perl: 37,552; makefile: 922; sh: 472; sql: 5
file content (195 lines) | stat: -rw-r--r-- 5,020 bytes parent folder | download
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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
package Lemonldap::NG::Handler::API::PSGI;

use strict;
our $VERSION = '1.9.1';

# Specific modules and constants for Test or CGI
use constant FORBIDDEN         => 403;
use constant HTTP_UNAUTHORIZED => 401;
use constant REDIRECT          => 302;
use constant OK                => 0;
use constant DECLINED          => 0;
use constant DONE              => 0;
use constant SERVER_ERROR      => 500;
use constant AUTH_REQUIRED     => 401;
use constant MAINTENANCE       => 503;
use Lemonldap::NG::Common::PSGI;

our $request;
#
## @method void setServerSignature(string sign)
# modifies web server signature
# @param $sign String to add to server signature
sub setServerSignature {
}

## @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 {

    # nothing to do in PSGI
}

## @method void newRequest($r)
# Store request in global $request variable
#
#@param $r Lemonldap::NG::Common::PSGI::Request
sub newRequest {
    my ( $class, $r ) = @_;
    $request                  = $r;
    $Lemonldap::NG::API::mode = 'PSGI';
}

## @method void lmLog(string $msg, string $level)
# logs message $msg to STDERR with level $level
# set Env Var lmLogLevel to set loglevel; set to "info" by default
# @param $msg string message to log
# @param $level string loglevel
BEGIN {
    *lmLog = *Lemonldap::NG::Common::PSGI::lmLog;
}

## @method void set_user(string user)
# sets remote_user in response headers
# @param user string username
sub set_user {
    my ( $class, $user ) = @_;
    $request->{respHeaders}->{'Lm-Remote-User'} = $user;
}

## @method string header_in(string header)
# returns request header value
# @param header string request header
# @return request header value
sub header_in {
    my ( $class, $header ) = @_;
    $header ||= $class;    # to use header_in as a method or as a function
    return $request->{ cgiName($header) };
}

## @method void set_header_in(hash headers)
# sets or modifies request headers
# @param headers hash containing header names => header value
sub set_header_in {
    my ( $class, %headers ) = @_;
    while ( my ( $h, $v ) = each %headers ) {
        $request->{ cgiName($h) } = $v;
    }
}

## @method void unset_header_in(array headers)
# removes request headers
# @param headers array with header names to remove
sub unset_header_in {
    my ( $class, @headers ) = @_;
    foreach my $h (@headers) {
        delete $request->{ cgiName($h) };
    }
}

## @method void set_header_out(hash headers)
# sets response headers
# @param headers hash containing header names => header value
sub set_header_out {
    my ( $class, %headers ) = @_;
    while ( my ( $h, $v ) = each %headers ) {
        $request->{respHeaders}->{$h} = $v;
    }
}

## @method string hostname
# returns host, as set by full URI or Host header
# @return host string Host value
sub hostname {
    my $h = $request->hostname;
    $h =~ s/:\d+//;
    return $h;
}

## @method string remote_ip
# returns client IP address
# @return IP_Addr string client IP
sub remote_ip {
    return $request->remote_ip;
}

## @method boolean is_initial_req
# always returns true
# @return is_initial_req boolean
sub is_initial_req {
    return 1;
}

## @method string args(string args)
# gets the query string
# @return args string Query string
sub args {
    return $request->query;
}

## @method string uri
# 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
# @return path portion of the URI, normalized
sub uri {
    return $request->uri;
}

## @method string uri_with_args
# returns the URI, with arguments and with path portion normalized
# @return URI with normalized path portion
sub uri_with_args {
    return $request->uri;
}

## @method string unparsed_uri
# returns the full original request URI, with arguments
# @return full original request URI, with arguments
sub unparsed_uri {
    return $request->unparsed_uri;
}

## @method string get_server_port
# returns the port the server is receiving the current request on
# @return port string server port
sub get_server_port {
    return $request->get_server_port;
}

## @method string method
# returns the request method
# @return port string server port
sub method {
    return $request->method;
}

## @method void print(string data)
# write data in HTTP response body
# @param data Text to add in response body
sub print {
    my ( $class, $data ) = @_;
    $request->{respBody} .= $data;
}

sub cgiName {
    my $h = uc(shift);
    $h =~ s/-/_/g;
    return "HTTP_$h";
}

sub addToHtmlHead {
    my $self = shift;
    $self->lmLog(
        'Features like form replay or logout_app can only be used with Apache',
        'error'
      ),
      ;
}

*setPostParams = *addToHtmlHead;

1;