## @file
# Base file for Lemonldap::NG handlers

## @class
# Base class for Lemonldap::NG handlers.
# All methods in handler are class methods: in ModPerl environment, handlers
# are always launched without object created.
#
# The main method is run() who is called by Apache for each requests (using
# handler() wrapper).
#
# The main initialization subroutine is init() who launch localInit() and
# globalInit().
package Lemonldap::NG::Handler::Simple;

use strict;

use MIME::Base64;
use Exporter 'import';
use AutoLoader 'AUTOLOAD';
use Safe;
use Lemonldap::NG::Common::Safelib;    #link protected safe Safe object
require POSIX;
use CGI::Util 'expires';
use constant SAFEWRAP => ( Safe->can("wrap_code_ref") ? 1 : 0 );

#inherits Cache::Cache
#inherits Apache::Session
#link Lemonldap::NG::Common::Apache::Session::SOAP protected globalStorage

our $VERSION = '1.1.2';

our %EXPORT_TAGS;

our @EXPORT_OK;

our @EXPORT;

# Shared variables
our (
    $locationRegexp,     $locationCondition,   $defaultCondition,
    $locationProtection, $defaultProtection,   $forgeHeaders,
    $apacheRequest,      $locationCount,       $cookieName,
    $datas,              $globalStorage,       $globalStorageOptions,
    $localStorage,       $localStorageOptions, $whatToTrace,
    $https,              $refLocalStorage,     $safe,
    $port,               $statusPipe,          $statusOut,
    $customFunctions,    $transform,           $cda,
    $childInitDone,      $httpOnly,            $cookieExpiration,
    $timeoutActivity,    $datasUpdate,         $useRedirectOnForbidden,
    $useRedirectOnError, $useSafeJail,
);

##########################################
# COMPATIBILITY WITH APACHE AND APACHE 2 #
##########################################

BEGIN {
    %EXPORT_TAGS = (
        localStorage =>
          [qw( $localStorage $localStorageOptions $refLocalStorage )],
        globalStorage => [qw( $globalStorage $globalStorageOptions )],
        locationRules => [
            qw(
              $locationCondition $defaultCondition $locationCount
              $locationProtection $defaultProtection $datasUpdate
              $locationRegexp $apacheRequest $datas safe $customFunctions
              $useSafeJail
              )
        ],
        import  => [qw( import @EXPORT_OK @EXPORT %EXPORT_TAGS )],
        headers => [
            qw(
              $forgeHeaders lmHeaderIn lmSetHeaderIn lmHeaderOut
              lmSetHeaderOut lmSetErrHeaderOut $cookieName $https $port
              )
        ],
        traces => [qw( $whatToTrace $statusPipe $statusOut)],
        apache => [
            qw( MP OK REDIRECT FORBIDDEN DONE DECLINED SERVER_ERROR
              $useRedirectOnForbidden $useRedirectOnError )
        ],
        post    => [qw($transform postFilter)],
        cda     => ['$cda'],
        cookie  => [qw($cookieName $https $httpOnly $cookieExpiration)],
        session => ['$timeoutActivity'],
    );
    push( @EXPORT_OK, @{ $EXPORT_TAGS{$_} } ) foreach ( keys %EXPORT_TAGS );
    $EXPORT_TAGS{all} = \@EXPORT_OK;
    if ( exists $ENV{MOD_PERL} ) {
        if ( $ENV{MOD_PERL_API_VERSION} and $ENV{MOD_PERL_API_VERSION} >= 2 ) {
            eval 'use constant MP => 2;';
        }
        else {
            eval 'use constant MP => 1;';
        }
    }
    else {
        eval 'use constant MP => 0;';
    }
    if ( MP() == 2 ) {
        require Apache2::Log;
        require Apache2::RequestUtil;
        Apache2::RequestUtil->import();
        require Apache2::RequestRec;
        Apache2::RequestRec->import();
        require Apache2::ServerUtil;
        Apache2::ServerUtil->import();
        require Apache2::Connection;
        Apache2::Connection->import();
        require Apache2::RequestIO;
        Apache2::RequestIO->import();
        require APR::Table;
        APR::Table->import();
        require Apache2::URI;
        Apache2::URI->import();
        require Apache2::Const;
        Apache2::Const->import( '-compile', qw(:common :log) );
        eval '
        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;
        ';
        eval {
            require threads::shared;
            threads::shared::share($locationRegexp);
            threads::shared::share($locationCondition);
            threads::shared::share($defaultCondition);
            threads::shared::share($locationProtection);
            threads::shared::share($defaultProtection);
            threads::shared::share($forgeHeaders);
            threads::shared::share($locationCount);
            threads::shared::share($cookieName);
            threads::shared::share($globalStorage);
            threads::shared::share($globalStorageOptions);
            threads::shared::share($localStorage);
            threads::shared::share($localStorageOptions);
            threads::shared::share($whatToTrace);
            threads::shared::share($https);
            threads::shared::share($port);
            threads::shared::share($refLocalStorage);
            threads::shared::share($statusPipe);
            threads::shared::share($statusOut);
            threads::shared::share($timeoutActivity);
            threads::shared::share($useRedirectOnForbidden);
            threads::shared::share($useRedirectOnError);
            threads::shared::share($useSafeJail);
        };
    }
    elsif ( MP() == 1 ) {
        require Apache;
        require Apache::Log;
        require Apache::Constants;
        Apache::Constants->import(':common');
        Apache::Constants->import(':response');
    }
    else {    # For Test or CGI
        eval '
        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;
        ';
    }
    *handler = ( MP() == 2 ) ? \&handler_mp2 : \&handler_mp1;
    *logout  = ( MP() == 2 ) ? \&logout_mp2  : \&logout_mp1;
}

## @rmethod protected int handler_mp2()
# Launch run() when used under mod_perl version 2
# @return Apache constant
sub handler_mp2 : method {
    shift->run(@_);
}

## @rmethod protected int logout_mp2()
# Launch unlog() when used under mod_perl version 2
# @return Apache constant
sub logout_mp2 : method {
    shift->unlog(@_);
}

## @rmethod void lmLog(string mess, string level)
# Wrapper for Apache log system
# @param $mess message to log
# @param $level string (debug, info, warning or error)
sub lmLog {
    my ( $class, $mess, $level ) = splice @_;
    die("Level is required") unless ($level);
    my $call;
    unless ( $level eq 'debug' ) {
        my @tmp = caller();
        $call = "$tmp[1] $tmp[2]:";
    }
    if ( MP() == 2 ) {
        Apache2::ServerRec->log->debug($call) if ($call);
        Apache2::ServerRec->log->$level($mess);
    }
    elsif ( MP() == 1 ) {
        Apache->server->log->debug($call) if ($call);
        Apache->server->log->$level($mess);
    }
    else {
        print STDERR "[$level] $mess\n";
    }
}

## @rmethod protected void lmSetApacheUser(Apache2::RequestRec r,string s)
# Inform Apache for the data to use as user for logs
# @param $r current request
# @param $s string to use
sub lmSetApacheUser {
    my ( $class, $r, $s ) = splice @_;
    return unless ($s);
    if ( MP() == 2 ) {
        $r->user($s);
    }
    else {
        $r->connection->user($s);
    }
}

## @ifn protected string protected regRemoteIp(string str)
# Replaces $ip by the client IP address in the string
# @param $str string
# @return string
sub regRemoteIp {
    my ( $class, $str ) = splice @_;
    if ( MP() == 2 ) {
        $str =~ s/\$datas->\{ip\}/\$apacheRequest->connection->remote_ip/g;
    }
    else {
        $str =~ s/\$datas->\{ip\}/\$apacheRequest->remote_ip/g;
    }
    return $str;
}

## @rmethod void lmSetHeaderIn(Apache2::RequestRec r, string h, string v)
# Set an HTTP header in the HTTP request.
# @param $r Current request
# @param $h Name of the header
# @param $v Value of the header
sub lmSetHeaderIn {
    my ( $class, $r, %hdr ) = splice @_;
    while ( my ( $h, $v ) = each %hdr ) {
        if ( MP() == 2 ) {
            $r->headers_in->set( $h => $v );
        }
        elsif ( MP() == 1 ) {
            $r->header_in( $h => $v );
        }
        $class->lmLog( "Send header $h with value $v", 'debug' );
    }
}

## @rfn string lmHeaderIn(Apache2::RequestRec r, string h)
# Return an HTTP header value from the HTTP request.
# @param $r Current request
# @param $h Name of the header
# @return Value of the header
sub lmHeaderIn {
    my ( $r, $h ) = splice @_;
    if ( MP() == 2 ) {
        return $r->headers_in->{$h};
    }
    elsif ( MP() == 1 ) {
        return $r->header_in($h);
    }
}

## @rfn void lmSetErrHeaderOut(Apache2::RequestRec r, string h, string v)
# Set an HTTP header in the HTTP response in error context
# @param $r Current request
# @param $h Name of the header
# @param $v Value of the header
sub lmSetErrHeaderOut {
    my ( $r, $h, $v ) = splice @_;
    if ( MP() == 2 ) {
        return $r->err_headers_out->set( $h => $v );
    }
    elsif ( MP() == 1 ) {
        return $r->err_header_out( $h => $v );
    }
}

## @rfn void lmSetHeaderOut(Apache2::RequestRec r, string h, string v)
# Set an HTTP header in the HTTP response in normal context
# @param $r Current request
# @param $h Name of the header
# @param $v Value of the header
sub lmSetHeaderOut {
    my ( $r, $h, $v ) = splice @_;
    if ( MP() == 2 ) {
        return $r->headers_out->set( $h => $v );
    }
    elsif ( MP() == 1 ) {
        return $r->header_out( $h => $v );
    }
}

## @rfn string lmHeaderOut(Apache2::RequestRec r, string h)
# Return an HTTP header value from the HTTP response.
# @param $r Current request
# @param $h Name of the header
# @return Value of the header
sub lmHeaderOut {
    my ( $r, $h, $v ) = splice @_;
    if ( MP() == 2 ) {
        return $r->headers_out->{$h};
    }
    elsif ( MP() == 1 ) {
        return $r->header_out($h);
    }
}

##############################
# Fake Safe jail subroutines #
##############################

## @method reval
# Fake reval method if useSafeJail desactivated
sub reval {
    my ( $class, $e ) = splice @_;
    return eval $e;
}

## @method wrap_code_ref
# Fake wrap_code_ref method if useSafeJail desactivated
sub wrap_code_ref {
    my ( $class, $e ) = splice @_;
    return $e;
}

## @method share
# Fake share method if useSafeJail desactivated
sub share {
    my ( $class, @vars ) = splice @_;
    $class->share_from( scalar(caller), \@vars );
}

## @method share_form
# Fake share_from method if useSafeJail desactivated
sub share_from {
    my ( $class, $pkg, $vars ) = splice @_;

    no strict 'refs';
    foreach my $arg (@$vars) {
        my ( $var, $type );
        $type = $1 if ( $var = $arg ) =~ s/^(\W)//;
        for ( 1 .. 2 ) {    # assign twice to avoid any 'used once' warnings
            *{$var} =
                ( !$type ) ? \&{ $pkg . "::$var" }
              : ( $type eq '&' ) ? \&{ $pkg . "::$var" }
              : ( $type eq '$' ) ? \${ $pkg . "::$var" }
              : ( $type eq '@' ) ? \@{ $pkg . "::$var" }
              : ( $type eq '%' ) ? \%{ $pkg . "::$var" }
              : ( $type eq '*' ) ? *{ $pkg . "::$var" }
              :                    undef;
        }
    }
}

##############################
# Initialization subroutines #
##############################

## @imethod protected Safe safe()
# Build and return the security jail used to compile rules and headers.
# @return Safe object
sub safe {
    my $class = shift;

    return $safe if ($safe);

    $useSafeJail = 1 unless defined $useSafeJail;

    my @t = $customFunctions ? split( /\s+/, $customFunctions ) : ();
    foreach (@t) {
        $class->lmLog( "Custom function : $_", 'debug' );
        my $sub = $_;
        unless (/::/) {
            $sub = "$class\::$_";
        }
        else {
            s/^.*:://;
        }
        next if ( $class->can($_) );
        eval "sub $_ {
            return $sub(\$apacheRequest->uri
                . ( \$apacheRequest->args ? '?' . \$apacheRequest->args : '' )
                , \@_)
            }";
        $class->lmLog( $@, 'error' ) if ($@);
    }

    if ($useSafeJail) {
        $safe = new Safe;
        $safe->share_from( 'main', ['%ENV'] );
    }
    else {
        $safe = $class;
    }

    # Share objets with Safe jail
    $safe->share_from( 'Lemonldap::NG::Common::Safelib',
        $Lemonldap::NG::Common::Safelib::functions );
    $safe->share( '&encode_base64', '$datas', '&portal', '$apacheRequest', @t );

    return $safe;
}

## @imethod void localInit(hashRef args)
# Call purgeCache() to purge the local cache, launch the status process
# (statusProcess()) in wanted and launch childInit().
# @param $args reference to the initialization hash
sub localInit($$) {
    my ( $class, $args ) = splice @_;
    if ( $localStorage = $args->{localStorage} ) {
        $localStorageOptions = $args->{localStorageOptions};
        $localStorageOptions->{namespace}          ||= "lemonldap";
        $localStorageOptions->{default_expires_in} ||= 600;
        $class->purgeCache();
    }
    if ( $args->{status} ) {
        if ( defined $localStorage ) {
            statusProcess();
        }
        else {

            # localStorage is mandatory for status module
            $class->lmLog(
"Status module can not be loaded without localStorage parameter",
                'warn'
            );
        }
    }
    $class->childInit($args);
}

## @imethod protected boolean childInit()
# Indicates to Apache that it has to launch:
# - initLocalStorage() for each child process (after fork and uid change)
# - cleanLocalStorage() after each requests
# @return True
sub childInit {
    my ( $class, $args ) = splice @_;
    return 1 if ($childInitDone);

    # We don't initialise local storage in the "init" subroutine because it can
    # be used at the starting of Apache and so with the "root" privileges. Local
    # Storage is also initialized just after Apache's fork and privilege lost.

    # Local storage is cleaned after giving the content of the page to increase
    # performances.
    no strict;
    if ( MP() == 2 ) {
        $s = Apache2::ServerUtil->server;
        $s->push_handlers( PerlChildInitHandler =>
              sub { return $class->initLocalStorage( $_[1], $_[0] ); } );
        $s->push_handlers(
            PerlPostConfigHandler => sub {
                my ( $c, $l, $t, $s ) = splice @_;
                $s->add_version_component(
                    'Lemonldap::NG::Handler/' . $VERSION );
            }
        ) unless ( $args->{hideSignature} );
    }
    elsif ( MP() == 1 ) {
        Apache->push_handlers(
            PerlChildInitHandler => sub { return $class->initLocalStorage(@_); }
        );
    }
    $childInitDone++;
    1;
}

## @imethod protected void purgeCache()
# Purge the local cache.
# Launched at Apache startup.
sub purgeCache {
    my $class = shift;
    eval "use $localStorage;";
    die("Unable to load $localStorage: $@") if ($@);

    # At each Apache (re)start, we've to clear the cache to avoid living
    # with old datas
    eval '$refLocalStorage = new ' . $localStorage . '($localStorageOptions);';
    if ( defined $refLocalStorage ) {
        $refLocalStorage->clear();
    }
    else {
        $class->lmLog( "Unable to clear local cache: $@", 'error' );
    }
}

## @imethod void globalInit(hashRef args)
# Global initialization process. Launch :
# - locationRulesInit()
# - defaultValuesInit()
# - portalInit()
# - globalStorageInit()
# - forgeHeadersInit()
# @param $args reference to the configuration hash
sub globalInit {
    my $class = shift;
    $class->portalInit(@_);
    $class->locationRulesInit(@_);
    $class->defaultValuesInit(@_);
    $class->globalStorageInit(@_);
    $class->forgeHeadersInit(@_);
    $class->postUrlInit(@_);
}

## @imethod protected codeRef conditionSub(string cond)
# Returns a compiled function used to grant users (used by
# locationRulesInit(). The second value returned is a boolean that
# tell if URL is protected.
# @param $cond The boolean expression to use
# @return array (ref(sub),boolean)
sub conditionSub {
    my ( $class, $cond ) = splice @_;
    my ( $OK, $NOK ) = ( sub { 1 }, sub { 0 } );

    # Simple cases : accept and deny
    return ( $OK, 1 )
      if ( $cond =~ /^accept$/i );
    return ( $NOK, 1 )
      if ( $cond =~ /^deny$/i );

    # Case unprotect : 2nd value is 0 since this URL is not protected
    return ( $OK, 0 )
      if ( $cond =~ /^unprotect$/i );

    # Case logout
    if ( $cond =~ /^logout(?:_sso)?(?:\s+(.*))?$/i ) {
        my $url = $1;
        return (
            $url
            ? ( sub { $datas->{_logout} = $url; return 0 }, 1 )
            : ( sub { $datas->{_logout} = portal(); return 0 }, 1 )
        );
    }

    # Since filter exists only with Apache>=2, logout_app and logout_app_sso
    # targets are available only for it.
    # This error can also appear with Manager configured as CGI script
    if ( $cond =~ /^logout_app/i and MP() < 2 ) {
        $class->lmLog( "Rules logout_app and logout_app_sso require Apache>=2",
            'warn' );
        return ( sub { 1 }, 1 );
    }

    # logout_app
    if ( $cond =~ /^logout_app(?:\s+(.*))?$/i ) {
        my $u = $1 || $class->portal();
        eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
        return (
            sub {
                $apacheRequest->add_output_filter(
                    sub {
                        return $class->redirectFilter( $u, @_ );
                    }
                );
                1;
            },
            1
        );
    }
    elsif ( $cond =~ /^logout_app_sso(?:\s+(.*))?$/i ) {
        eval 'use Apache2::Filter' unless ( $INC{"Apache2/Filter.pm"} );
        my $u = $1 || $class->portal();
        return (
            sub {
                $class->localUnlog;
                $apacheRequest->add_output_filter(
                    sub {
                        return $class->redirectFilter(
                            $class->portal() . "?url="
                              . $class->encodeUrl($u)
                              . "&logout=1",
                            @_
                        );
                    }
                );
                1;
            },
            1
        );
    }

    # Replace some strings in condition
    $cond =~ s/\$date/&POSIX::strftime("%Y%m%d%H%M%S",localtime())/e;
    $cond =~ s/\$(\w+)/\$datas->{$1}/g;
    $cond =~ s/\$datas->{vhost}/\$apacheRequest->hostname/g;

    # Eval sub
    my $sub = (
        SAFEWRAP
        ? $class->safe->wrap_code_ref(
            $class->safe->reval("sub{return($cond)}")
          )
        : $class->safe->reval("sub{return($cond)}")
    );

    # Return sub and protected flag
    return ( $sub, 1 );
}

## @imethod protected void defaultValuesInit(hashRef args)
# Set default values for non-customized variables
# @param $args reference to the configuration hash
sub defaultValuesInit {
    my ( $class, $args ) = splice @_;

    # Warning: first start of handler load values from MyHanlder.pm
    # and lemonldap-ng.ini
    # These values should be erased by global configuration!
    $cookieName  = $args->{cookieName}  || $cookieName  || 'lemonldap';
    $whatToTrace = $args->{whatToTrace} || $whatToTrace || 'uid';
    $whatToTrace =~ s/\$//g;
    $https = defined($https) ? $https : $args->{https};
    $args->{securedCookie} = 1 unless defined( $args->{securedCookie} );
    $cookieName .= 'http' if ( $args->{securedCookie} == 2 and $https == 0 );
    $port ||= $args->{port};
    $customFunctions  = $args->{customFunctions};
    $cda              = defined($cda) ? $cda : $args->{cda};
    $httpOnly         = defined($httpOnly) ? $httpOnly : $args->{httpOnly};
    $cookieExpiration = $args->{cookieExpiration} || $cookieExpiration;
    $timeoutActivity  = $args->{timeoutActivity} || $timeoutActivity || 0;
    $useRedirectOnError =
      defined($useRedirectOnError)
      ? $useRedirectOnError
      : $args->{useRedirectOnError};
    $useRedirectOnForbidden =
      defined($useRedirectOnForbidden)
      ? $useRedirectOnForbidden
      : $args->{useRedirectOnForbidden};
    $useSafeJail =
      defined($useSafeJail)
      ? $useSafeJail
      : $args->{useSafeJail};
    1;
}

## @imethod protected void portalInit(hashRef args)
# Verify that portal variable exists. Die unless
# @param $args reference to the configuration hash
sub portalInit {
    my ( $class, $args ) = splice @_;
    die("portal parameter required") unless ( $args->{portal} );
    if ( $args->{portal} =~ /[\$\(&\|"']/ ) {
        my ($portal) = $class->conditionSub( $args->{portal} );
        eval "sub portal {return &\$portal}";
    }
    else {
        eval "sub portal {return '$args->{portal}'}";
    }
    die("Unable to read portal parameter ($@)") if ($@);
    1;
}

## @imethod protected void globalStorageInit(hashRef args)
# Initialize the Apache::Session::* module choosed to share user's variables.
# @param $args reference to the configuration hash
sub globalStorageInit {
    my ( $class, $args ) = splice @_;
    $globalStorage = $args->{globalStorage}
      or die("globalStorage required");
    eval "use $globalStorage;";
    die($@) if ($@);
    $globalStorageOptions = $args->{globalStorageOptions};
}

## @imethod protected int initLocalStorage()
# Prepare local cache (if not done before by Lemonldap::NG::Common::Conf)
# @return Apache2::Const::DECLINED
sub initLocalStorage {
    my ( $class, $r ) = splice @_;
    if ( $localStorage and not $refLocalStorage ) {
        eval
"use $localStorage;\$refLocalStorage = new $localStorage(\$localStorageOptions);";
        $class->lmLog( "Local cache initialization failed: $@", 'error' )
          unless ( defined $refLocalStorage );
    }
    return DECLINED;
}

###################
# RUNNING METHODS #
###################

## @rmethod protected void updateStatus(string user,string url,string action)
# Inform the status process of the result of the request if it is available.
sub updateStatus {
    my ( $class, $user, $url, $action ) = splice @_;
    eval {
            print $statusPipe "$user => "
          . $apacheRequest->hostname
          . "$url $action\n"
          if ($statusPipe);
    };
}

## @rmethod protected int forbidden(string uri)
# Used to reject non authorizated requests.
# Inform the status processus and call logForbidden().
# @param uri URI requested
# @return Apache2::Const::REDIRECT or Apache2::Const::FORBIDDEN
sub forbidden {
    my ( $class, $uri ) = splice @_;
    if ( $datas->{_logout} ) {
        $class->updateStatus( $datas->{$whatToTrace}, $_[0], 'LOGOUT' );
        my $u = $datas->{_logout};
        $class->localUnlog;
        return $class->goToPortal( $u, 'logout=1' );
    }
    $class->updateStatus( $datas->{$whatToTrace}, $_[0], 'REJECT' );
    $apacheRequest->push_handlers(
        PerlLogHandler => sub {
            $_[0]->status(FORBIDDEN);
            $class->logForbidden( $uri, $datas );
            DECLINED;
        }
    );

    # Redirect or Forbidden?
    if ($useRedirectOnForbidden) {
        $class->lmLog( "Use redirect for forbidden access", 'debug' );
        return $class->goToPortal( $uri, 'lmError=403' );
    }
    else {
        $class->lmLog( "Return forbidden access", 'debug' );
        return FORBIDDEN;
    }
}

## @rmethod protected void logForbidden(string uri,hashref datas)
# Insert a log in Apache errors log system to inform that the user was rejected.
# This method has to be overloaded to use different logs systems
# @param $uri uri asked
# @param $datas hash re to user's datas
sub logForbidden {
    my ( $class, $uri, $datas ) = splice @_;
    $class->lmLog(
        'User "'
          . $datas->{$whatToTrace}
          . '" was reject when he tried to access to '
          . $uri,
        'notice'
    );
}

## @rmethod protected void logGranted(string uri)
# Insert a log in Apache errors log system to inform that the user was
# authorizated. This method has to be overloaded to use different logs systems
# @param $uri uri asked
sub logGranted {
    my ( $class, $uri, $datas ) = splice @_;
    $class->lmLog(
        'User "'
          . $datas->{$whatToTrace}
          . '" was granted to access to '
          . $uri,
        'debug'
    );
}

## @rmethod protected void hideCookie()
# Hide Lemonldap::NG cookie to the protected application.
sub hideCookie {
    my $class = shift;
    $class->lmLog( "$class: removing cookie", 'debug' );
    my $tmp = lmHeaderIn( $apacheRequest, 'Cookie' );
    $tmp =~ s/$cookieName(?:http)?[^,;]*[,;]?//og;
    $class->lmSetHeaderIn( $apacheRequest, 'Cookie' => $tmp );
}

## @rmethod protected string encodeUrl(string url)
# Encode URl in the format used by Lemonldap::NG::Portal for redirections.
# @return Base64 encoded string
sub encodeUrl {
    my ( $class, $url ) = splice @_;
    $url = $class->_buildUrl($url) if ( $url !~ m#^https?://# );
    return encode_base64( $url, '' );
}

## @rmethod protected int goToPortal(string url, string arg)
# Redirect non-authenticated users to the portal by setting "Location:" header.
# @param $url Url requested
# @param $arg optionnal GET parameters
# @return Apache2::Const::REDIRECT
sub goToPortal {
    my ( $class, $url, $arg ) = splice @_;
    $class->lmLog(
        "Redirect "
          . $apacheRequest->connection->remote_ip
          . " to portal (url was $url)",
        'debug'
    );
    my $urlc_init = $class->encodeUrl($url);
    lmSetHeaderOut( $apacheRequest,
            'Location' => $class->portal()
          . "?url=$urlc_init"
          . ( $arg ? "&$arg" : "" ) );
    return REDIRECT;
}

## @rmethod protected $ fetchId()
# Get user cookies and search for Lemonldap::NG cookie.
# @return Value of the cookie if found, 0 else
sub fetchId {
    my $t = lmHeaderIn( $apacheRequest, 'Cookie' );
    return ( $t =~ /$cookieName=([^,; ]+)/o ) ? $1 : 0;
}

# MAIN SUBROUTINE called by Apache (using PerlHeaderParserHandler option)

## @rmethod int run(Apache2::RequestRec apacheRequest)
# Main method used to control access.
# Calls :
# - fetchId()
# - lmSetApacheUser()
# - grant()
# - forbidden() if user is rejected
# - sendHeaders() if user is granted
# - hideCookie()
# - updateStatus()
# @param $apacheRequest Current request
# @return Apache2::Const value (OK, FORBIDDEN, REDIRECT or SERVER_ERROR)
sub run ($$) {
    my $class;
    ( $class, $apacheRequest ) = splice @_;
    return DECLINED unless ( $apacheRequest->is_initial_req );
    my $args = $apacheRequest->args;

    # Cross domain authentication
    if ( $cda and $args =~ s/[\?&]?($cookieName=\w+)$//oi ) {
        my $str = $1;
        $class->lmLog( 'CDA request', 'debug' );
        $apacheRequest->args($args);
        my $host          = $apacheRequest->get_server_name();
        my $redirectUrl   = $class->_buildUrl( $apacheRequest->uri );
        my $redirectHttps = ( $redirectUrl =~ m/^ĥttps/ );
        lmSetErrHeaderOut( $apacheRequest,
            'Location' => $redirectUrl . ( $args ? "?" . $args : "" ) );
        $host =~ s/^[^\.]+\.(.*\..*$)/$1/;
        lmSetErrHeaderOut(
            $apacheRequest,
            'Set-Cookie' => "$str; domain=$host; path=/"
              . ( $redirectHttps ? "; secure"   : "" )
              . ( $httpOnly      ? "; HttpOnly" : "" )
              . (
                $cookieExpiration
                ? "; expires=" . expires( $cookieExpiration, 'cookie' )
                : ""
              )
        );
        return REDIRECT;
    }
    my $uri = $apacheRequest->uri . ( $args ? "?$args" : "" );
    Apache2::URI::unescape_url($uri);

    # AUTHENTICATION
    # I - recover the cookie
    my $id;
    unless ( $id = $class->fetchId ) {

        # 1.1 Ignore unprotected URIs
        unless ( $class->isProtected($uri) ) {
            $class->updateStatus( $apacheRequest->connection->remote_ip,
                $apacheRequest->uri, 'UNPROTECT' );
            return OK;
        }

        # 1.2 Redirect users to the portal
        $class->lmLog( "$class: No cookie found", 'info' );
        $class->updateStatus( $apacheRequest->connection->remote_ip,
            $apacheRequest->uri, 'REDIRECT' );
        return $class->goToPortal($uri);
    }

    # II - recover the user datas
    #  2.1 search if the user was the same as previous (very efficient in
    #      persistent connection).
    unless ( $id eq $datas->{_session_id} and ( time() - $datasUpdate < 60 ) ) {

        # 2.2 search in the local cache if exists
        unless ( $refLocalStorage and $datas = $refLocalStorage->get($id) ) {

            # 2.3 search in the central cache
            my %h;
            eval { tie %h, $globalStorage, $id, $globalStorageOptions; };
            if ($@) {

                # The cookie isn't yet available
                $class->lmLog( "The cookie $id isn't yet available: $@",
                    'info' );
                $class->updateStatus( $apacheRequest->connection->remote_ip,
                    $apacheRequest->uri, 'EXPIRED' );

                # For unprotected URI, user is not redirected
                unless ( $class->isProtected($uri) ) {
                    $class->updateStatus( $apacheRequest->connection->remote_ip,
                        $apacheRequest->uri, 'UNPROTECT' );
                    return OK;
                }
                return $class->goToPortal($uri);
            }

            # Update the session to notify activity, if necessary
            $h{_lastSeen} = time() if ($timeoutActivity);

            # Store data in current shared variables
            $datas->{$_} = $h{$_} foreach ( keys %h );

            # Store now the user in the local storage
            if ($refLocalStorage) {
                $refLocalStorage->set( $id, $datas, "10 minutes" );
            }
            untie %h;
            $datasUpdate = time();
        }
    }

    # ACCOUNTING
    # 1 - Inform Apache
    $class->lmSetApacheUser( $apacheRequest, $datas->{$whatToTrace} );

    # AUTHORIZATION
    my $kc = keys %$datas;
    return $class->forbidden($uri) unless ( $class->grant($uri) );
    $class->updateStatus( $datas->{$whatToTrace}, $apacheRequest->uri, 'OK' );

    # Store local macros
    if ( keys %$datas > $kc and $refLocalStorage ) {
        $class->lmLog( "Update local cache", "debug" );
        $refLocalStorage->set( $id, $datas, "10 minutes" );
    }

    # ACCOUNTING
    # 2 - Inform remote application
    $class->sendHeaders;

    # SECURITY
    # Hide Lemonldap::NG cookie
    $class->hideCookie;

    # Log
    $apacheRequest->push_handlers(
        PerlLogHandler => sub { $class->logGranted( $uri, $datas ); DECLINED },
    );

    #  Catch POST rules
    $class->transformUri($uri);

    # Return OK
    OK;
}

1;
__END__

=head1 NAME

=encoding utf8

Lemonldap::NG::Handler::Simple - Perl base extension for building Lemonldap::NG
compatible handler.

=head1 SYNOPSIS

Create your own package:

  package My::Package;
  use Lemonldap::NG::Handler::Simple;

  our @ISA = qw(Lemonldap::NG::Handler::Simple);

  __PACKAGE__->init ({
         locationRules        => {
               default          => '$ou =~ /brh/'
         },
         globalStorage        => 'Apache::Session::MySQL',
         globalStorageOptions => {
               DataSource       => 'dbi:mysql:database=dbname;host=127.0.0.1',
               UserName         => 'db_user',
               Password         => 'db_password',
               TableName        => 'sessions',
               LockDataSource   => 'dbi:mysql:database=dbname;host=127.0.0.1',
               LockUserName     => 'db_user',
               LockPassword     => 'db_password',
           },
         localStorage         => 'Cache::DBFile',
         localStorageOptions  => {},
         portal               => 'https://portal/',
       });

More complete example

  package My::Package;
  use Lemonldap::NG::Handler::Simple;

  our @ISA = qw(Lemonldap::NG::Handler::Simple);

  __PACKAGE__->init ( { locationRules => {
             '^/pj/.*$'       => '$qualif="opj"',
             '^/rh/.*$'       => '$ou=~/brh/',
             '^/rh_or_opj.*$' => '$qualif="opj" or $ou=~/brh/',
             default => 'accept', # means that all authenticated users are greanted
           },
           globalStorage        => 'Apache::Session::MySQL',
           globalStorageOptions => {
               DataSource       => 'dbi:mysql:database=dbname;host=127.0.0.1',
               UserName         => 'db_user',
               Password         => 'db_password',
               TableName        => 'sessions',
               LockDataSource   => 'dbi:mysql:database=dbname;host=127.0.0.1',
               LockUserName     => 'db_user',
               LockPassword     => 'db_password',
           },
           localStorage         => 'Cache::DBFile',
           localStorageOptions  => {},
           cookieName           => 'lemon',
           portal               => 'https://portal/',
           whatToTrace          => '$uid',
           exportedHeaders      => {
               'Auth-User'      => '$uid',
               'Unit'           => '$ou',
           https                => 1,
         }
       );

Call your package in <apache-directory>/conf/httpd.conf

  PerlRequire MyFile
  # TOTAL PROTECTION
  PerlHeaderParserHandler My::Package
  # OR SELECTED AREA
  <Location /protected-area>
    PerlHeaderParserHandler My::Package
  </Location>
  
You can also unprotect an URI

  <Files "*.gif">
    PerlHeaderParserHandler My::Package->unprotect
  </Files>

=head1 DESCRIPTION

Lemonldap::NG::Handler::Simple is designed to be overloaded. See
L<Lemonldap::NG::Handler> for more.

=head2 INITIALISATION PARAMETERS

This section presents the C<init> method parameters.

=over

=item B<locationRules> (required)

Reference to a hash that contains "url-regexp => perl-expression" entries to
manage authorizations.

=over

=item * "url-regexp" can be a perl regexp or the keyword 'default' which
corresponds to the default police (accept by default).

=item * "perl-expression" can be a perl condition or the keyword "accept" or the
keyword "deny". All the variables announced by $<name of the variable> are
replaced by the values resulting from the global session store.

=back

=item B<globalStorage> E<amp> B<globalStorageOptions> (required)

Name and parameters of the Apache::Session::* module used by the portal to
store user's datas. See L<Lemonldap::NG::Portal(3)> for more explanations.

=item B<localStorage> E<amp> B<localStorageOptions>

Name and parameters of the optional but recommended Cache::* module used to
share user's datas between Apache processes. There is no need to set expires
options since L<Lemonldap::NG::Handler::Simple> call the Cache::*::purge
method itself.

=item B<cookieName> (default: lemon)

Name of the cookie used by the Lemonldap::NG infrastructure.

=item B<portal> (required)

Url of the portal used to authenticate users.

=item B<whatToTrace> (default: uid)

Stored user variable to use in Apache logs.

=item B<exportedHeaders>

Reference to a hash that contains "Name => value" entries. Those headers are
calculated for each user by replacing the variables announced by "$" by their
values resulting from the global session store.

=item B<https> (default: 1)

Indicates if the protected server is protected by SSL. It is used to build
redirections, so you have to set it to avoid bad redirections after
authentication.

=item B<port> (default: undef)

If port is not well defined in redirection, you can fix listen port here.

=back

=head2 EXPORT

None by default. You can import the following tags for inheritance:

=over

=item * B<:localStorage> : variables used to manage local storage

=item * B<:globalStorage> : variables used to manage global storage

=item * B<:locationRules> : variables used to manage area protection

=item * B<:import> : import function inherited from L<Exporter> and related
variables

=item * B<:headers> : functions and variables used to manage custom HTTP
headers exported to the applications

=item * B<apache> : functions and variables used to dialog with mod_perl.
This is done to be compatible both with Apache 1 and 2.

=back

=head1 SEE ALSO

L<Lemonldap::NG::Handler>, L<Lemonldap::NG::Portal>,
L<http://lemonldap-ng.org/>

=head1 AUTHOR

Xavier Guimard, E<lt>x.guimard@free.frE<gt>

=head1 BUG REPORT

Use OW2 system to report bug or ask for features:
L<http://jira.ow2.org>

=head1 DOWNLOAD

Lemonldap::NG is available at
L<http://forge.objectweb.org/project/showfiles.php?group_id=274>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005, 2007, 2010 by Xavier Guimard E<lt>x.guimard@free.frE<gt>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut
## @rmethod int abort(string mess)
# Logs message and exit or redirect to the portal if "useRedirectOnError" is
# set to true.
# @param $mess Message to log
# @return Apache2::Const::REDIRECT or Apache2::Const::SERVER_ERROR
sub abort {
    my ( $class, $mess ) = splice @_;

    # If abort is called without a valid request, fall to die
    eval {
        my $args = $apacheRequest->args;
        my $uri = $apacheRequest->uri . ( $args ? "?$args" : "" );

        # Set error 500 in logs even if "useRedirectOnError" is set
        $apacheRequest->push_handlers(
            PerlLogHandler => sub { $_[0]->status(SERVER_ERROR); DECLINED; } );
        $class->lmLog( $mess, 'error' );

        # Redirect or die
        if ($useRedirectOnError) {
            $class->lmLog( "Use redirect for error", 'debug' );
            return $class->goToPortal( $uri, 'lmError=500' );
        }
        else {
            return SERVER_ERROR;
        }
    };
    die $mess if ($@);
}

## @rmethod protected int handler_mp1()
# Launch run() when used under mod_perl version 1
# @return Apache constant
sub handler_mp1 ($$) { shift->run(@_); }

## @rmethod protected int logout_mp1()
# Launch unlog() when used under mod_perl version 1
# @return Apache constant
sub logout_mp1 ($$) { shift->unlog(@_); }

## @imethod void init(hashRef args)
# Calls localInit() and globalInit().
# @param $args reference to the initialization hash
sub init($$) {
    my $class = shift;
    $class->localInit(@_);
    $class->globalInit(@_);
}

## @imethod protected void locationRulesInit(hashRef args)
# Compile rules.
# Rules are stored in $args->{locationRules} that contains regexp=>test
# expressions where :
# - regexp is used to test URIs
# - test contains an expression used to grant the user
#
# This function creates 2 arrays containing :
# - the list of the compiled regular expressions
# - the list of the compiled functions (compiled with conditionSub())
# @param $args reference to the configuration hash
sub locationRulesInit {
    my ( $class, $args ) = splice @_;
    $locationCount = 0;

    # Pre compilation : both regexp and conditions
    foreach ( sort keys %{ $args->{locationRules} } ) {
        if ( $_ eq 'default' ) {
            ( $defaultCondition, $defaultProtection ) =
              $class->conditionSub( $args->{locationRules}->{$_} );
        }
        else {
            (
                $locationCondition->[$locationCount],
                $locationProtection->[$locationCount]
            ) = $class->conditionSub( $args->{locationRules}->{$_} );
            $locationRegexp->[$locationCount] = qr/$_/;
            $locationCount++;
        }
    }

    # Default police: all authenticated users are accepted
    ( $defaultCondition, $defaultProtection ) = $class->conditionSub('accept')
      unless ($defaultCondition);
    1;
}

## @imethod protected void forgeHeadersInit(hashRef args)
# Create the &$forgeHeaders subroutine used to insert
# headers into the HTTP request.
# @param $args reference to the configuration hash
sub forgeHeadersInit {
    my ( $class, $args ) = splice @_;

    # Creation of the subroutine who will generate headers
    my %tmp;
    if ( $args->{exportedHeaders} ) {
        %tmp = %{ $args->{exportedHeaders} };
    }
    else {
        %tmp = ( 'User-Auth' => '$uid' );
    }
    foreach ( keys %tmp ) {
        $tmp{$_} =~ s/\$(\w+)/\$datas->{$1}/g;
        $tmp{$_} = $class->regRemoteIp( $tmp{$_} );
    }

    my $sub;
    foreach ( keys %tmp ) {
        $sub .= "'$_' => join('',split(/[\\r\\n]+/,$tmp{$_})),";
    }
    $forgeHeaders = (
        SAFEWRAP
        ? $class->safe->wrap_code_ref( $class->safe->reval("sub{$sub}") )
        : $class->safe->reval("sub{return($sub)}")
    );
    $class->lmLog( "$class: Unable to forge headers: $@: sub {$sub}", 'error' )
      if ($@);
    1;
}

## @imethod protected buildPostForm(string url, int count)
# Build form that will be posted by client
# Fill an input hidden with fake value to
# reach the size of initial request
# @param url Target of POST
# @param count Fake input size
# @return Apache2::Const::OK
sub buildPostForm {
    my $class = shift;
    my $url   = shift;
    my $count = shift || 1000;
    $apacheRequest->handler("perl-script");
    $apacheRequest->set_handlers(
        'PerlResponseHandler' => sub {
            my $r = shift;
            $r->content_type('text/html; charset=UTF-8');
            $r->print(
qq{<html><body onload="document.getElementById('f').submit()"><form id="f" method="post" action="$url"><input type=hidden name="a" value="}
                  . sprintf( "%0" . $count . "d", 1 )
                  . qq{"/><input type="submit" value="Ok"/></form></body></html>}
            );
            OK;
        }
    );
    OK;
}

## @rmethod protected void sendHeaders()
# Launch function compiled by forgeHeadersInit()
sub sendHeaders {
    my ($class) = splice @_;
    $class->lmSetHeaderIn( $apacheRequest, &$forgeHeaders );
}

## @rmethod protected boolean isProtected()
# @return True if URI isn't protected (rule "unprotect")
sub isProtected {
    my ( $class, $uri ) = splice @_;
    for ( my $i = 0 ; $i < $locationCount ; $i++ ) {
        return $locationProtection->[$i]
          if ( $uri =~ $locationRegexp->[$i] );
    }
    return $defaultProtection;
}

## @rmethod protected boolean grant(string uri)
# Grant or refuse client using compiled regexp and functions
# @param uri URI requested
# @return True if the user is granted to access to the current URL
sub grant {
    my ( $class, $uri ) = splice @_;
    for ( my $i = 0 ; $i < $locationCount ; $i++ ) {
        return &{ $locationCondition->[$i] }($datas)
          if ( $uri =~ $locationRegexp->[$i] );
    }
    return &$defaultCondition($datas);
}

## @imethod protected void postUrlInit()
# Prepare methods to post form attributes
sub postUrlInit {
    my ( $class, $args ) = splice @_;

    # Do nothing if no POST configured
    return unless ( $args->{post} );

    # Load required modules
    eval 'use Apache2::Filter;use URI';

    # Prepare transform sub
    $transform = {};

    #  Browse all POST URI
    while ( my ( $url, $d ) = each( %{ $args->{post} } ) ) {

        # Where to POST
        $d->{postUrl} ||= $url;

        # Register POST form for POST URL
        $transform->{ $d->{postUrl} } =
          sub { $class->buildPostForm( $d->{postUrl} ) }
          if ( $url ne $d->{postUrl} );

        # Get datas to POST
        my $expr = $d->{expr};
        my %postdata;

        # Manage old and new configuration format
        # OLD: expr => 'param1 => value1, param2 => value2',
        # NEW : expr => { param1 => value1, param2 => value2 },
        if ( ref $expr eq 'HASH' ) {
            %postdata = %$expr;
        }
        else {
            %postdata = split /(?:\s*=>\s*|\s*,\s*)/, $expr;
        }

        # Build string for URI::query_form
        my $tmp;
        foreach ( keys %postdata ) {
            $postdata{$_} =~ s/\$(\w+)/\$datas->{$1}/g;
            $postdata{$_} = "'$postdata{$_}'" if ( $postdata{$_} =~ /^\w+$/ );
            $tmp .= "'$_'=>$postdata{$_},";
        }

        $class->lmLog( "Compiling POST request for $url", 'debug' );
        $transform->{$url} = sub {
            return $class->buildPostForm($url)
              if ( $apacheRequest->method ne 'POST' );
            $apacheRequest->add_input_filter(
                sub {
                    $class->postFilter( $tmp, @_ );
                }
            );
            OK;
          }
    }
}

## @rmethod protected int postFilter(hashref data, Apache2::Filter f)
# POST data
# @param $data Data to POST
# @param $f Current Apache2::Filter object
# @return Apache2::Const::OK
sub postFilter {
    my $class = shift;
    my $data  = shift;
    my $f     = shift;
    my $l;

    unless ( $f->ctx ) {
        $f->ctx(1);
        my $u = URI->new('http:');
        $u->query_form( { $class->safe->reval($data) } );
        my $s = $u->query();
        $l = $f->r->headers_in->{'Content-Length'};
        $f->r->headers_in->set( 'Content-Length' => length($s) );
        $f->r->headers_in->set(
            'Content-Type' => 'application/x-www-form-urlencoded' );
        $f->print($s);
        while ( $f->read( my $b, $l ) ) { }
        $f->seen_eos(1);
    }
    return OK;
}

## @rmethod protected transformUri(string uri)
# Transform URI to replay POST forms
# @param uri URI to catch
# @return Apache2::Const
sub transformUri {
    my ( $class, $uri ) = splice @_;

    if ( defined( $transform->{$uri} ) ) {
        return &{ $transform->{$uri} };
    }

    OK;
}

## @method private string _buildUrl(string s)
# Transform /<s> into http(s?)://<host>:<port>/s
# @param $s path
# @return URL
sub _buildUrl {
    my ( $class, $s ) = splice @_;
    my $portString = $port || $apacheRequest->get_server_port();
    $portString =
        ( $https  && $portString == 443 ) ? ''
      : ( !$https && $portString == 80 )  ? ''
      :                                     ':' . $portString;
    return
        "http"
      . ( $https ? "s" : "" ) . "://"
      . $apacheRequest->get_server_name()
      . $portString
      . $s;
}

# Status daemon creation

## @ifn protected void statusProcess()
# Launch the status processus.
sub statusProcess {
    require IO::Pipe;
    $statusPipe = IO::Pipe->new;
    $statusOut  = IO::Pipe->new;
    if ( my $pid = fork() ) {
        $statusPipe->writer();
        $statusOut->reader();
        $statusPipe->autoflush(1);
    }
    else {
        require Data::Dumper;
        $statusPipe->reader();
        $statusOut->writer();
        my $fdin  = $statusPipe->fileno;
        my $fdout = $statusOut->fileno;
        open STDIN,  "<&$fdin";
        open STDOUT, ">&$fdout";
        my @tmp = ();
        push @tmp, "-I$_" foreach (@INC);
        exec 'perl', '-MLemonldap::NG::Handler::Status',
          @tmp,
          '-e',
          '&Lemonldap::NG::Handler::Status::run('
          . $localStorage . ','
          . Data::Dumper->new( [$localStorageOptions] )->Terse(1)->Dump . ');';
    }
}

## @rmethod int unprotect()
# Used to unprotect an area.
# To use it, set "PerlHeaderParserHandler My::Package->unprotect" Apache
# configuration file.
# It replace run() by doing nothing.
# @return Apache2::Const::OK
sub unprotect {
    OK;
}

## @rmethod protected void localUnlog()
# Delete current user from local cache entry.
sub localUnlog {
    my $class = shift;
    if ( my $id = $class->fetchId ) {

        # Delete Apache thread datas
        if ( $id eq $datas->{_session_id} ) {
            $datas = {};
        }

        # Delete Apache local cache
        if ( $refLocalStorage and $refLocalStorage->get($id) ) {
            $refLocalStorage->remove($id);
        }
    }
}

## @rmethod protected int unlog(Apache::RequestRec apacheRequest)
# Call localUnlog() then goToPortal() to unlog the current user.
# @return Apache2::Const value returned by goToPortal()
sub unlog ($$) {
    my $class;
    ( $class, $apacheRequest ) = splice @_;
    $class->localUnlog;
    $class->updateStatus( $apacheRequest->connection->remote_ip,
        $apacheRequest->uri, 'LOGOUT' );
    return $class->goToPortal( '/', 'logout=1' );
}

## @rmethod protected int redirectFilter(string url, Apache2::Filter f)
# Launch the current HTTP request then redirects the user to $url.
# Used by logout_app and logout_app_sso targets
# @param $url URL to redirect the user
# @param $f Current Apache2::Filter object
# @return Apache2::Const::OK
sub redirectFilter {
    my $class = shift;
    my $url   = shift;
    my $f     = shift;
    unless ( $f->ctx ) {

        # Here, we can use Apache2 functions instead of lmSetHeaderOut because
        # this function is used only with Apache2.
        $f->r->status(REDIRECT);
        $f->r->status_line("303 See Other");
        $f->r->headers_out->unset('Location');
        $f->r->err_headers_out->set( 'Location' => $url );
        $f->ctx(1);
    }
    while ( $f->read( my $buffer, 1024 ) ) {
    }
    $class->updateStatus(
        (
              $datas->{$whatToTrace}
            ? $datas->{$whatToTrace}
            : $f->r->connection->remote_ip
        ),
        'filter',
        'REDIRECT'
    );
    return OK;
}

## @rmethod int status(Apache2::RequestRec $r)
# Get the result from the status process and launch a PerlResponseHandler to
# display it.
# @param $r Current request
# @return Apache2::Const::OK
sub status($$) {
    my ( $class, $r ) = splice @_;
    $class->lmLog( "$class: request for status", 'debug' );
    return $class->abort("$class: status page can not be displayed")
      unless ( $statusPipe and $statusOut );
    $r->handler("perl-script");
    print $statusPipe "STATUS" . ( $r->args ? " " . $r->args : '' ) . "\n";
    my $buf;
    while (<$statusOut>) {
        last if (/^END$/);
        $buf .= $_;
    }
    if ( MP() == 2 ) {
        $r->push_handlers(
            'PerlResponseHandler' => sub {
                my $r = shift;
                $r->content_type('text/html; charset=UTF-8');
                $r->print($buf);
                OK;
            }
        );
    }
    else {
        $r->push_handlers(
            'PerlHandler' => sub {
                my $r = shift;
                $r->content_type('text/html; charset=UTF-8');
                $r->send_http_header;
                $r->print($buf);
                OK;
            }
        );
    }
    return OK;
}