lemonldap-ng/lemonldap-ng-handler/lib/Lemonldap/NG/Handler/API/ApacheMP2.pm

package Lemonldap::NG::Handler::API::ApacheMP2;

use Exporter 'import';

our $VERSION = '1.4.0';
our ( %EXPORT_TAGS, @EXPORT_OK, @EXPORT );

BEGIN{
    %EXPORT_TAGS = (
        httpCodes => [
            qw( OK REDIRECT FORBIDDEN DONE DECLINED SERVER_ERROR AUTH_REQUIRED )
        ],
    );
    push( @EXPORT_OK, @{ $EXPORT_TAGS{$_} } ) foreach ( keys %EXPORT_TAGS );
    $EXPORT_TAGS{all} = \@EXPORT_OK;
}

# Specific modules and constants for Apache Mod_Perl 2
use Apache2::RequestUtil;
use Apache2::RequestRec;
use Apache2::Log;
use Apache2::ServerUtil;
use Apache2::Connection;
use Apache2::RequestIO;
use Apache2::Const;
use APR::Table;

use constant FORBIDDEN    => Apache2::Const::FORBIDDEN;
use constant REDIRECT     => Apache2::Const::REDIRECT;
use constant OK           => Apache2::Const::OK;
use constant DECLINED     => Apache2::Const::DECLINED;
use constant DONE         => Apache2::Const::DONE;
use constant SERVER_ERROR => Apache2::Const::SERVER_ERROR;
use constant AUTH_REQUIRED => Apache2::Const::AUTH_REQUIRED;

eval { require threads::shared; };
print STDERR "You probably would have better perfs by enabling threads::shared\n"
    if ($@);

my $request; # Apache2::RequestRec object for current request

## @method void thread_share(string $variable)
# try to share $variable between threads
# note: eval is needed,
# else it fails to compile if threads::shared is not loaded
# @param $variable the name of the variable to share
sub thread_share {
    my ($class, $variable) = @_;
    eval "threads::shared::share(\$variable);";
}

## @method void setServerSignature(string sign)
# modifies web server signature
# @param $sign String to add to server signature  
sub setServerSignature {
    my ($class, $sign) = @_;
    Apache2::ServerUtil->server->push_handlers(
        PerlPostConfigHandler => sub {
            my ( $c, $l, $t, $s ) = splice @_;
            $s->add_version_component($sign);
        }
    );
}

sub newRequest {
    my ( $class, $r ) = @_;
    $request = $r;
}

## @method void lmLog(string $msg, string $level)
# logs message $msg to Apache logs with loglevel $level
# @param $msg string message to log
# @param $level string loglevel
sub lmLog {
    my ( $class, $msg, $level ) = @_;
    # TODO: remove the useless tag 'ApacheMP2.pm(70):' in debug logs
    Apache2::ServerRec->log->$level($msg);
}

## @method void set_user(string user)
# sets remote_user
# @param user string username
sub set_user {
    my ($class, $user) = @_;
    $request->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) = @_;
    return $request->headers_in->{$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->headers_in->set( $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) {
        $request->headers_in->unset($h);
    }
} 

## @method void set_header_out(hash headers)
# sets response headers, only on 2xx and 3xx responses
# @param headers hash containing header names => header value
sub set_header_out {
    my ($class, %headers) = @_;
    while ( my ( $h, $v ) = each %headers ) {
        $request->headers_out->set( $h => $v );
    }
}

## @method void set_err_header_out(hash headers)
# sets response headers, even on 4xx responses
# @param headers hash containing header names => header value
sub set_err_header_out {
    my ($class, %headers) = @_;
    while ( my ( $h, $v ) = each %headers ) {
        $request->err_headers_out->set( $h => $v );
    }
}

## @method string hostname()
# returns host, as set by full URI or Host header
# @return host string Host value
sub hostname {
    my $class = shift;
    return $request->hostname;
}

## @method string remote_ip
# returns client IP address
# @return IP_Addr string client IP
sub remote_ip {
    my $class = shift;
    return $request->connection->remote_ip;
}

## @method boolean is_initial_req
# returns true unless the current request is a subrequest
# @return is_initial_req boolean
sub is_initial_req {
    my $class = shift;
    return $request->is_initial_req;
}

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

## @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 {
    my $class = shift;
    my $uri = $request->uri;
    $uri =~ s#//+#/#g;
    $uri =~ s#\?#%3F#g;
    return $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 {
    my $class = shift;
    return $class->uri($request)
        . ( $request->args ? "?" . $request->args : "");
}

## @method string unparsed_uri
# returns the full original request URI, with arguments
# @return full original request URI, with arguments
sub unparsed_uri {
    my $class = shift;
    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 {
    my $class = shift;
    return $request->get_server_port;
}

## @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->print($data);
}

1;