2014-05-23 15:35:47 +02:00
|
|
|
package Lemonldap::NG::Handler::API::CGI;
|
|
|
|
|
2014-06-13 18:12:54 +02:00
|
|
|
use Exporter 'import';
|
|
|
|
|
2014-05-23 17:21:10 +02:00
|
|
|
our $VERSION = '1.4.0';
|
2014-06-17 21:22:36 +02:00
|
|
|
our ( %EXPORT_TAGS, @EXPORT_OK, @EXPORT );
|
2014-06-13 18:12:54 +02:00
|
|
|
|
|
|
|
BEGIN{
|
|
|
|
%EXPORT_TAGS = (
|
2014-06-16 11:44:39 +02:00
|
|
|
httpCodes => [
|
2014-06-13 18:12:54 +02:00
|
|
|
qw( OK REDIRECT FORBIDDEN DONE DECLINED SERVER_ERROR )
|
|
|
|
],
|
|
|
|
);
|
|
|
|
push( @EXPORT_OK, @{ $EXPORT_TAGS{$_} } ) foreach ( keys %EXPORT_TAGS );
|
|
|
|
$EXPORT_TAGS{all} = \@EXPORT_OK;
|
2014-06-17 21:22:36 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
# Specific modules and constants for Test or CGI
|
|
|
|
use constant FORBIDDEN => 1;
|
|
|
|
use constant REDIRECT => 1;
|
|
|
|
use constant OK => 1;
|
|
|
|
use constant DECLINED => 1;
|
|
|
|
use constant DONE => 1;
|
|
|
|
use constant SERVER_ERROR => 1;
|
|
|
|
|
2014-06-13 18:12:54 +02:00
|
|
|
|
2014-06-17 21:22:36 +02:00
|
|
|
## @method void apiInit(hashref $args)
|
|
|
|
# nothing do to at startup
|
|
|
|
# @param $args the name of the variable to share
|
|
|
|
sub apiInit {
|
|
|
|
my ($class, $args) = @_;
|
2014-06-13 18:12:54 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
## @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 CGI
|
|
|
|
}
|
|
|
|
|
2014-06-09 19:09:48 +02:00
|
|
|
## @method void set_user(Apache2::RequestRec request, string user)
|
|
|
|
# sets remote_user
|
|
|
|
# @param request Apache2::RequestRec current request
|
|
|
|
# @param user string username
|
2014-05-23 15:35:47 +02:00
|
|
|
sub set_user {
|
2014-06-08 12:04:50 +02:00
|
|
|
my ( $class, $r, $user ) = @_;
|
2014-05-23 15:35:47 +02:00
|
|
|
$ENV{REMOTE_USER} = $user;
|
|
|
|
}
|
|
|
|
|
2014-06-09 19:09:48 +02:00
|
|
|
## @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
|
2014-05-23 17:21:10 +02:00
|
|
|
sub header_in {
|
2014-06-08 12:04:50 +02:00
|
|
|
my ( $class, $r, $header ) = @_;
|
2014-05-23 17:21:10 +02:00
|
|
|
return $ENV{ cgiName($header) };
|
|
|
|
}
|
|
|
|
|
2014-06-09 19:09:48 +02:00
|
|
|
## @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
|
2014-05-23 17:21:10 +02:00
|
|
|
sub set_header_in {
|
2014-06-08 12:04:50 +02:00
|
|
|
my ( $class, $r, %headers ) = @_;
|
2014-05-23 17:21:10 +02:00
|
|
|
while ( my ( $h, $v ) = each %headers ) {
|
|
|
|
$ENV{ cgiName($h) } = $v;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2014-06-09 19:09:48 +02:00
|
|
|
## @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
|
2014-05-23 17:21:10 +02:00
|
|
|
sub unset_header_in {
|
2014-06-08 12:04:50 +02:00
|
|
|
my ( $class, $r, @headers ) = @_;
|
2014-05-23 17:21:10 +02:00
|
|
|
foreach my $h (@headers) {
|
|
|
|
$ENV{ cgiName($h) } = undef;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2014-06-09 19:09:48 +02:00
|
|
|
## @method void set_header_out(Apache2::RequestRec request, hash headers)
|
|
|
|
# sets response headers, only on 2xx and 3xx responses
|
|
|
|
# @param request Apache2::RequestRec current request
|
|
|
|
# @param headers hash containing header names => header value
|
2014-05-23 17:21:10 +02:00
|
|
|
sub set_header_out {
|
2014-06-08 12:04:50 +02:00
|
|
|
my ( $class, $r, %headers ) = @_;
|
2014-05-23 17:21:10 +02:00
|
|
|
while ( my ( $h, $v ) = each %headers ) {
|
2014-06-08 12:04:50 +02:00
|
|
|
|
2014-05-23 17:21:10 +02:00
|
|
|
# TODO
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2014-06-09 19:09:48 +02:00
|
|
|
## @method void set_err_header_out(Apache2::RequestRec request, hash headers)
|
|
|
|
# sets response headers, even on 4xx responses
|
|
|
|
# @param request Apache2::RequestRec current request
|
|
|
|
# @param headers hash containing header names => header value
|
2014-05-23 17:21:10 +02:00
|
|
|
sub set_err_header_out {
|
2014-06-08 12:04:50 +02:00
|
|
|
my ( $class, $r, %headers ) = @_;
|
2014-05-23 17:21:10 +02:00
|
|
|
while ( my ( $h, $v ) = each %headers ) {
|
2014-06-08 12:04:50 +02:00
|
|
|
|
2014-05-23 17:21:10 +02:00
|
|
|
# TODO
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2014-06-09 19:09:48 +02:00
|
|
|
## @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 $ENV{SERVER_NAME};
|
|
|
|
}
|
|
|
|
|
|
|
|
## @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 $ENV{REMOTE_ADDR};
|
|
|
|
}
|
|
|
|
|
|
|
|
## @method boolean is_initial_req(Apache2::RequestRec request)
|
|
|
|
# always returns true
|
|
|
|
# @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)
|
2014-06-13 14:14:44 +02:00
|
|
|
# gets the query string
|
2014-06-09 19:09:48 +02:00
|
|
|
# @param request Apache2::RequestRec current request
|
|
|
|
# @return args string Query string
|
|
|
|
sub args {
|
2014-06-13 14:14:44 +02:00
|
|
|
my ($class, $r) = @_;
|
2014-06-09 19:09:48 +02:00
|
|
|
return $ENV{QUERY_STRING};
|
|
|
|
}
|
|
|
|
|
|
|
|
## @method string uri(Apache2::RequestRec request)
|
|
|
|
# returns the path portion of the URI, normalized, i.e. :
|
2014-06-13 14:14:44 +02:00
|
|
|
# * URL decoded (characters encoded as %XX are decoded,
|
|
|
|
# except ? in order not to merge path and query string)
|
2014-06-09 19:09:48 +02:00
|
|
|
# * 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 = $ENV{SCRIPT_NAME};
|
|
|
|
$uri =~ s#//+#/#g;
|
2014-06-13 14:14:44 +02:00
|
|
|
$uri =~ s#\?#%3F#g;
|
2014-06-09 19:09:48 +02:00
|
|
|
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) . ( $ENV{QUERY_STRING} ? "?$ENV{QUERY_STRING}" : "");
|
|
|
|
}
|
|
|
|
|
|
|
|
## @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 $ENV{REQUEST_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 $ENV{SERVER_PORT};
|
|
|
|
}
|
|
|
|
|
|
|
|
sub push_handlers {
|
|
|
|
my ($class, $r) = @_;
|
|
|
|
}
|
|
|
|
|
2014-05-23 17:21:10 +02:00
|
|
|
sub cgiName {
|
|
|
|
my $h = uc(shift);
|
|
|
|
$h =~ s/-/_/g;
|
|
|
|
return "HTTP_$h";
|
|
|
|
}
|
|
|
|
|
2014-05-23 15:35:47 +02:00
|
|
|
1;
|