#=============================================================================
# General Doloforge Mason service setup. This Perl script creates all needed
# stuff for Doloforge Perl/Mason back-end Apache server.
# This script is designed from HTML::Mason::Admin man page and samples.
#
# It must be linked from apache2 config directory, as explained in
# /etc/doloforge/apache2.conf (which PerlRequire's this script)
#
# Testing this script can be done using:
#   apache2ctl configtest
#=============================================================================


#=============================================================================
# Package name referenced in VirtualHost snippets, as in:
#   <LocationMatch "\.(phtml|mason|md|mc)$">
#       SetHandler  perl-script
#       PerlHandler Doloforge::Mason
#       DefaultType text/html
#   </LocationMatch>
#
package Doloforge::Mason;

use common::sense;
#use strict;
#use utf8;

# Apache modules
use Apache2::Status;
# Mason-related packages
use HTML::Mason;                # Main Mason package
use CGI;
use HTML::Mason::ApacheHandler;
# HTML::Mason uses Exception::Class, which does not fit correctly with Error::Simple's syntactic sugar...
# From man Exception::Class :
# OTHER EXCEPTION MODULES (try/catch syntax)
#   If you are interested in adding try/catch/finally syntactic sugar to
#   your code then I recommend you check out U. Arun Kumar's "Error.pm"
#   module, which implements this syntax.  It also includes its own base
#   exception class, "Error::Simple".
#   If you would prefer to use the "Exception::Class::Base" class included
#   with this module, you'll have to add this to your code somewhere:
#push (@Exception::Class::Base::ISA, 'Error::Simple')
#    unless Exception::Class::Base->isa('Error::Simple');

# Doloforge-related packages
use Config::YAML;               # Main doloforge configuration file parser (/etc/doloforge/doloforge.yaml)
use Sys::Hostname;
use File::Path;
use File::Basename;
use MIME::QuotedPrint;


#=============================================================================
# Read full Doloforge config file and setup the running environment
my $doloforge = Config::YAML->new(config => '/etc/doloforge/doloforge.yaml');

# Read the include'd files defined in the main configuration under the "include:" array key
foreach my $file (@{$doloforge->{include}}) {
    # Read the file in a new hash object
    my $include = Config::YAML->new(config => "$doloforge->{dir}->{conf}/$file");

    # The included configuration keys take precedence over all previously defined configuration keys.
    # Ignore the Config::YAML system specific keys (starting with "_" : "_infile", "_outfile", etc.)
    map {$doloforge->{$_} = $include->{$_} unless ($_ =~ m/^_/)} keys(%$include);
}

# A little hack in the configuration : "host:" is set with the hostname,
# if not already set in the config file. This allows to set a fake hostname
# for testing purposes.
# hostname is exported by Sys::Hostname
$doloforge->{host} = hostname unless (exists($doloforge->{host}));

# Identify the current back-end from configuration directory /etc/apache2-${APACHE_STAGE}.${APACHE_BACKEND}
my $confdir = (grep(m{/etc/apache2}, @INC))[0];
my ($stage, $backend, $version) = ($confdir =~ m{/etc/apache2-(\w+)\.(\w+)(?:\.(\w+)|)$});
# Read the port number from ports.conf
open(PORT, "<$confdir/ports.conf");
my $port = undef;
while (<PORT>) {
    ($port) = (m{^Listen\s+(\d+)\s*$});
    last if $port;
};
close(PORT);

# The working directories which are created upton startup should be more admin-friendly than default root umask=0022
umask 0002;


#=============================================================================
# Include path for client-related packages.
# Packages that are require'd in this script must reside in a static directory, and must not change.
# We must "use lib" because "use GHS::" below is evaluated at compile-time, before we read the config file for more paths to add to @INC.
#   cp -a /srv/doloforge/devl/edition/lib/perl/GHS/App* /etc/doloforge/lib/perl/GHS
#   cp -a /srv/doloforge/devl/edition/lib/perl/GHS/Exception.pm /etc/doloforge/lib/perl/GHS
# This whole trick should really be replaced with properly installed packages in system-wide directories.
use lib "/etc/doloforge/lib/perl";
# Platform-wide client packages will be loaded from those dynamically configured lib dirs.
# Client-specific require'd packages are located later-on while processing each request (see @INC below).
unshift(@INC, map { "$doloforge->{stages}->{$stage}->{dir}->{shared}/$_/lib/perl" } @{$doloforge->{lib_client}});


#=============================================================================
# This is the package HTML::Mason components will run inside: load any modules
# here. These modules are loaded once for all, and share memory between Apache
# children processes. No need to reload them in each component or script...
#
{
    #package Doloforge::Mason::Commands;
    package HTML::Mason::Commands;

    use common::sense;
    #use utf8;

    # Variables globales.
    # "use vars" in order to have those variables imported in component execution scope.
    # "my" won't do it automagically.
    use vars qw(%session $dbh $app);

    # Deux modules nécessaires à la gestion des sessions.
    # L'initialisation se fait plus bas.
    use CGI; # Pour les upload de fichiers
    use CGI::Util qw(expires);
    use CGI::Cookie;
    $CGI::POST_MAX = 20 * 1024 * 1024; # 20230623/NH : passé de 10Mo à 20Mo
    use Apache::Session::File;

    # Pour accéder aux bases de données/fichier plats SQL
    use Apache::DBI;
    #$Apache::DBI::DEBUG = 2;
    use DBD::Pg;

    use Apache::AuthDBI;
    Apache::AuthDBI->setCacheTime(180);
    Apache::AuthDBI->setCleanupTime(180);
    Apache::AuthDBI->initIPC(50000);
    #$Apache::AuthDBI::DEBUG = 2;

    # 20180913/NH : needed only by http://admin.edition.devl.public.doloforge.com/, which can use Apache::AuthDBI...
    #use GHS::AuthDBI;
    #GHS::AuthDBI->setCacheTime(180);
    #GHS::AuthDBI->setCleanupTime(180);
    #GHS::AuthDBI->initIPC(25000);
    ##$GHS::AuthDBI::DEBUG = 2;

    # Le serveur d'application GHS et la gestion d'erreurs
    use Error qw(:try);
    $Error::Debug = 1;
    use GHS::AppServ; # Number::Format 
    use GHS::AppObj;

    # Divers use standards chargés usuellement.
    use Data::Dumper;

    use POSIX;
    use File::Copy;
    use File::Path;
    use File::Basename;
    use File::Temp qw(tempfile tempdir);
    use IPC::Open2;

    use HTTP::Headers;
    use HTTP::Request;
    use HTTP::Response;
    use LWP::UserAgent;
    use MIME::QuotedPrint;
    use JSON::XS; # encode_json/decode_json; my $json = JSON::XS->new->utf8(0)->allow_nonref;

    use IO::Scalar;
    #use Spreadsheet::WriteExcel;

    use Unicode::String qw(utf8 latin1 utf16);
    use Encode qw(decode encode);
}


#=============================================================================
# Escape functions
#
my %html_escape = ('&' => '&amp;', '>'=>'&gt;', '<'=>'&lt;', '"'=>'&quot;', "\n" => '<br>', "\r" => '');
my $html_escape = qr/([&<>"\n\r])/;
sub basic_html_escape_with_para
{
    return unless defined ${ $_[0] };
    ${ $_[0] } =~ s/$html_escape/$html_escape{$1}/mg;
}

sub javascript_escape
{
    return unless defined ${ $_[0] };
    # Encapsule le code HTML généré par le composant dans des instructions JavaScript
    ${ $_[0] } =~ s/\\/\\\\/go;             # Echappe les \ du texte HTML pour que le JS les laisse tels quels
    ${ $_[0] } =~ s/'/\\'/go;               # Echappe les ' du texte HTML pour ne pas clasher avec les ' encadrant les chaînes JS
    ${ $_[0] } =~ s/<\//<'+'\//go;          # Remplace les </ par une concaténation de chaînes JS, afin que les </script> éventuels ne soient pas considérés comme la fin de ce script-ci
    ${ $_[0] } =~ s/\r\n/'+"\\r\\n"+'/go;   # Remplace les \r\n par une concaténation de chaine pour que ces derniers apparaissent dans le code js
    ${ $_[0] } =~ s/\r/'+"\\r"+'/go;        # idem pour les \r...
    ${ $_[0] } =~ s/\n/'+"\\n"+'/go;        # ...et pour les \n seuls...
}

sub rich_text_escape
{
    return unless defined ${ $_[0] };
    # Encode le texte en HTML enrichi : les escapes HTML normaux sont appliqués, avec en plus des encodages *gras*, /ital/, etc.
    #${ $_[0] } =~ s/([<>&\n])/$html_escape{$1}/mgoe;
    ${ $_[0] } =~ s/$html_escape/$html_escape{$1}/mg;
    ${ $_[0] } =~ s/( |^)\*(\S.*?\S)\*($|\W)/$1<b>$2<\/b>$3/mgo;   # Traitement des *gras*
    ${ $_[0] } =~ s/( |^)\/(\S.*?\S)\/($|\W)/$1<i>$2<\/i>$3/mgo;   # Traitement des /ital/
    ${ $_[0] } =~ s/( |^)\_(\S.*?\S)\_($|\W)/$1<u>$2<\/u>$3/mgo;   # Traitement des _souligné_
    ${ $_[0] } =~ s{(https?://[\w.?=%/@&;-]+)}{<a href="$1">$1</a>}mgo;         # Crée un <a href> autour des liens http(s)://...
    ${ $_[0] } =~ s{mailto:([\w.?=%/@&;-]+)}{<a href="mailto:$1">$1</a>}mgo;    # Crée un <a href> autour des liens mailto:...
    # 20141104/NH : ne marche apparemment pas au moins sur un exemple JIM...
    #${ $_[0] } =~ s/( |^)(http:\/\/[\w|\.|\?|\=|\%|\/|\-]+)(\/|\w)($|\b| |\.)/$1<a href\=\"$2$3\">$2$3<\/a>$4/mgo;   # Crée un bon <a href> autour des liens http://...
    #${ $_[0] } =~ s/( |^)(mailto:)([\w|\.|\_|\-|\@]+)(\w)($|\b| |\.)/$1<a href\=\"$2$3$4\">$3$4<\/a>$5/mgo;          # Crée un bon <a href> autour des liens mailto://...
    # 20141023/NH : je supprime ce remplacement qui permet de créer de vrais tags HTML à partir d'entrée non validée (donc XSS, fake, etc...)
    #${ $_[0] } =~ s/\[\[([^<>\[\]]+?)\]\]/<$1>/mgo;                # Remplace les [[tag]] par des <tag> HTML (tag ne doit pas contenir de [, ], <, >)
}

sub url_escape
{
    return unless defined ${ $_[0] };
    use bytes;
    ${ $_[0] } =~ s/([^a-zA-Z0-9 _.,:-])/uc sprintf("%%%02x",ord($1))/eg;
    ${ $_[0] } =~ s/ /+/g;
}

sub quotedprintable_escape
{
    return unless defined ${ $_[0] };
    ${ $_[0] } = substr(encode_qp(${ $_[0] }), 0, -2);
}

# Escape flags shared by all handlers
my $escape_flags = {
    h => \&HTML::Mason::Escapes::basic_html_escape, # h - html escape (basic 1.0x version)
    p => \&basic_html_escape_with_para,             # p - html + \n escape
    j => \&javascript_escape,                       # j - javascript escape (in the context of a '' string)
    r => \&rich_text_escape,                        # r - rich-text escape (*bold*, /ital/, etc.)
    u => \&url_escape,                              # u - replaces some characters with the URL-escaped equivalent, a percent sign (%) followed by the hexadecimal number, replaces space with '+'
    q => \&quotedprintable_escape,                  # q - quoted-printable escape, without \r\n at the end
};

#=============================================================================
# Create Mason objects
#
# Prepare many $ah and select the correct one for each request, based on mode in project conf
my %ah = (); # hash keyed for one handler per mode, etc.
# Mode the project is in (ie. "devl" = with debugging and no cache for developers; "prod" = under a proper domain name for real users; anything else = neutral, neither developpers nor real users)
foreach my $mode ('devl', '_default_') {
    # Create a handler for each stage, tuned for the mode of that stage
    $ah{$mode} = new HTML::Mason::ApacheHandler (
        # cf. HTML::Mason::Params(3pm)
        comp_root => ($doloforge->{stages}->{$stage}->{dir}->{shared} or $doloforge->{dir}->{shared})."/.doloforge/$backend/components",
        data_dir => "$doloforge->{dir}->{varcache}/$backend/data-$stage",
        # Make sure the whole compiled component code is taken as UTF-8 text, and files read/created from there is also validated UTF-8.
        #   http://perldoc.perl.org/open.html
        # Évite d'ajouter des transcodages conditionnels un peu partout.
        #   edition/lib/perl/Edition/Document.pm, edition/lib/perl/Mail/Sender.pm : binmode(OUT, ":encoding(utf8)") if ($] >= 5.024);
        #   inc/navigation.mc, inc/texte_integral.mc : $yaml_data = decode('utf8', $yaml_data) if ($] >= 5.024);
        # The preamble parameter will not take effect within %once and %shared sections, which makes it useless for the UTF-8 need.
        # The use_strict value depends on a hack to HTML/Mason/Compiler/ToObject.pm, which will insert it instead of "use strict;\n".
        #   307 # 20180911/NH : properly encode in UTF8 even in the once sections
        #   308 #$self->use_strict ? "use strict;\n" : "no strict;\n",
        #   309 $self->use_strict ? ($self->use_strict == 1 ? "use strict;\n" : $self->use_strict) : "no strict;\n",
        #   310 # 20180911/NH : end
        #preamble => 'use utf8;',
        use_strict => join("\n", 'use common::sense;', 'use open ":encoding(utf8)";', ''),
        #in_package => "Doloforge::Mason::Commands::$stage", # <%filter> sections do not know $m when using this...
        plugins => ['MasonX::Plugin::UTF8'],
        args_method => 'CGI', # 'mod_perl',
        data_cache_api => '1.0',
        escape_flags => $escape_flags,
        # Error reporting and caching behaviour is similar to front-end handling (cf. skel/template/apache_httpd.conf.tmpl)
        ($mode eq 'devl' ? (
            # in development mode, errors are output to the browser, there is no Mason cache, no ErrorDocument, etc.
            error_mode => 'output',
            data_cache_defaults => { cache_class => 'NullCache', },
        ) : (
            # in production mode, errors are only logged, cache and ErrorDocument are enabled
            error_mode => 'fatal',
            data_cache_defaults => { cache_class => 'FileCache', },
        )),
        # 20180913/NH : test the performance improvement
        #static_source => 1,
        #static_source_touch_file => "$doloforge->{dir}->{varcache}/$backend/data-$stage/static_source_touch_file",
    );
}


# Locate and create sessions and locks directories from the Doloforge configuration
#my $sessions_dir = "$doloforge->{dir}->{shared}/.doloforge/mason/sessions";
my $sessions_dir = "$doloforge->{dir}->{varlib}/mason/sessions";
my $sessions_lck = "$doloforge->{dir}->{varlib}/mason/sessions-lock";
mkpath $sessions_dir unless (-e $sessions_dir);
mkpath $sessions_lck unless (-e $sessions_lck);

# Activate the following if running httpd as root (the normal case).
# Resets ownership of all files created by Mason at startup.
chown(Apache2::ServerUtil->user_id, $doloforge->{permissions}->{group}->[1], $sessions_dir, $sessions_lck, map { $_->interp()->files_written } (values(%ah)));

# Files are uploaded or created via Apache, thus from "the entire world",
# thus world-writable files make then sense, thus no umask...
# We create a Mason writable directory by setting mode o+w (world-writable),
# making logical the subsequent world-writable sub-dirs and files.
umask 0000;


#=============================================================================
# PerlInitHandler
# Use this to create the Auth_DBI_data_source PerlSetVar-equivalent for use by
# every handler (ie. for Apache::AuthDBI to work).
#
sub init {
    my ($r) = @_;

    # 20070817/NH : ajout pour que le nom de la base et du répertoire spécifique ne soient pas "devinés" par le code des composants...
    # Ce code est identique à ce qui se trouve ci-dessous, et correspond à edition/admin/conf/mason_postgres7_httpd.conf.tmpl
    if (my $dbname = $r->dir_config("dbname")) {
        $dbname =~ s/(\{[^\}]+\})/eval($1)/eg;
        $r->dir_config->set("dbname", $dbname);
        #$r->log_error("dir_config->set('dbname', $dbname)");
    }

    if (my $dsn = $r->dir_config("DBIDataSource")) {
        # Le DSN trouvé dans le fichier de conf peut contenir des couples {}
        # contenant des expressions Perl évaluées. On peut par exemple placer
        #   PerlSetVar DBIDataSource "DBI:Pg:dbname={ $r->hostname =~ /^([^.]+)/; $1 };host=db-server"
        # Cette expression va utiliser $r->hostname (de la forme
        # vininfos.admin-edition.be) pour en extraire la première partie et
        # l'utiliser comme nom de base de données (ici vininfos).
        # Ceci n'est valable que si on ajoute le PerlInitHandler qui
        # utilise cette fonction, de manière à protéger les sites normaux.
        # Une fois l'évaluation effectuée, son résultat est conservé dans la
        # configuration Apache, et n'a donc plus à être ré-évalué par la suite.
        $dsn =~ s/(\{[^\}]+\})/eval($1)/eg;
        $r->dir_config->set("DBIDataSource", $dsn);
        $r->dir_config->set("Auth_DBI_data_source", $dsn);
        #$r->log_error("dir_config->set('DBIDataSource', $dsn)");
    }

    return 0; # Apache::Constants::OK
}

#=============================================================================
# PerlHandler
# This is the fonction that is called by Apache to process
# the current request.
#
sub handler
{
    my ($r) = @_;

    my ($status);

    undef $HTML::Mason::Commands::dbh;
    # The my variable is NOT between parens in order to evaluate the
    # assignment in scalar context, that returns the affected value...
    if (my $dsn = $r->dir_config("DBIDataSource")) {
        $HTML::Mason::Commands::dbh = DBI->connect(
            $dsn,
            undef, # username
            undef, # password
            {
                RaiseError => 1,
                AutoCommit => 0,
            }
        ) or die("DBI connect error with [$dsn] : $DBI::errstr", $r->uri);
        # Start with a rollback to ignore all previous requests (... and reset 'now()')
        $HTML::Mason::Commands::dbh->rollback();
    }

    # Identify the session key, sent by the browser in a cookie
    my %cookies = CGI::Cookie->parse($r->headers_in->{'Cookie'}) if ($r->headers_in->{'Cookie'});
    my $cookie = ($cookies{'DSID'} && $cookies{'DSID'}->value());

    # Expires values are set from MasonSessionCookieExpires :
    #   default : '+12h'
    #   allowed values from CGI::Cookie, ie. : '+15m'
    #   keep cookie in memory : 'memory'
    #   do not use cookies at all : 'no_session'
    # The my variable is NOT between parens in order to evaluate the
    # affectation in scalar context, that returns the affected value...
    my $expires = $r->dir_config('MasonSessionCookieExpires') || '+12h';

    # Try hard (but not loop forever) to create a tied session from the cookie,
    # but only if the cookie sent is not "no_session", in which case we don't
    # tie the session hash, and don't send back a new cookie.
    # The {{}} is for redo to work : it's bound to a loop, but do isn't a loop
    # From man perlsyn :
    #    the loop control statements described later will NOT work
    #    in this construct, because modifiers don't take loop
    #    labels.  Sorry.  You can always put another block inside
    #    of it (for "next") or around it (for "last") to do that
    #    sort of thing.  For "next", just double the braces:
    #    
    #       do {{
    #           next if $x == $y;
    #           # do something here
    #       }} until $x++ > $z;
    do {{
        eval {
            tie(%HTML::Mason::Commands::session,
                'Apache::Session::File',
                $cookie,
                {
                    'Directory' => $sessions_dir,
                    'LockDirectory' => $sessions_lck,
                    'Transaction' => 1,
                }
            );
        };
        # If there is an error, whatever it is, log and redo once
        if ($@) {
            # This kind of error is effectively triggered by proxies and
            # so on, so we don't really log them.
            # Really interesting errors is when a browser loses it's
            # session ID and we create a new one. This event is seen in
            # the access_log, when session ID changes. There is no other
            # way to log it.
            #$r->log_error('tie \%HTML::Mason::Commands::session, DSID=' . (defined($cookie) ? "'$cookie'" : '(undef)') . " : $@");

            # Undefine $cookie and redo if it was not already undefined : redo once
            if ($cookie) {
                undef($cookie);
                redo;
            }
        }
    # Regexp historique d'identification des robots : m/(spider|crawl|bot|slurp|scooter|seek|publish|pompos|archiver|track|urllib|perl|wget|facebookexternalhit)/i
    # Mise à jour 20210901 : m/(https?:|mailto:|bot|spider|fetcher|crawl|publish|external|archive|track|python-|aiohttp|libwww-perl|wget|curl)/i
    # Pour tester, coller des UserAgent dans la commande suivante :
    #   nhuillard@krypton:~$ perl -n -e 'print m/(https?:|mailto:|bot|spider|fetcher|crawl|publish|external|archive|track|python-|aiohttp|libwww-perl|wget|curl)/i ? "-> robot\n" : "-> browser\n"'
    #       Mozilla/5.0 (iPhone; CPU iPhone OS 15_0 like Mac OS X) AppleWebKit/605.1.15 (KHTML, like Gecko) Version/15.0 Mobile/15E148 Safari/604.1
    #       -> browser
    #       Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/94.0.4606.71 Safari/537.36
    #       -> browser
    #       Mozilla/5.0 (compatible; AhrefsBot/7.0; +http://ahrefs.com/robot/)
    #       -> robot
    }} if (($expires ne 'no_session') and ($cookie ne 'no_session')
        and (defined($cookie) or ($r->headers_in->get('User-Agent') !~ m/(https?:|mailto:|bot|spider|fetcher|crawl|publish|external|archive|track|python-|aiohttp|libwww-perl|wget|curl)/i)));


    # If there is a real tied session with it's _session_id, we can send back the cookie
    if ($HTML::Mason::Commands::session{'_session_id'}) {
        $HTML::Mason::Commands::session{'_count'}++;
        # If this is a newly created session, add some easy debugging info in it
        unless (exists($HTML::Mason::Commands::session{'_created'})) {
            $HTML::Mason::Commands::session{'_created'} = scalar(localtime);    # identify long-lasting sessions
            $HTML::Mason::Commands::session{'_hostname'} = $r->hostname();      # easily identify the project
            $HTML::Mason::Commands::session{'_ip'} = $r->useragent_ip();        # keep the initial IP of the browser, just in case
        }

        # The cookie is resent on each request in order to replace its expiration date...
        $cookie = new CGI::Cookie(
            -name => 'DSID',
            -value => $HTML::Mason::Commands::session{'_session_id'},
            -path => '/',
            # 20210622/NH : réglages de cookie plus sûrs en prod, au détriment de devl (qui n'a pas de HTTPS) ou des sites non HTTPS qui ont besoin de cookie de session
            #   * pour ajuster les paramètres de Firefox about:config filter selon "samesite" :
            #       network.cookie.sameSite.laxByDefault    false
            #       network.cookie.sameSite.laxByDefault.disabledHosts
            #       network.cookie.sameSite.laxPlusPOST.timeout 120
            #       network.cookie.sameSite.noneRequiresSecure  false
            #   * pour que les sites en devl sans https fonctionnent, il faut sans doute :
            #       laxByDefault = false
            #       noneRequiresSecure = false
            #-samesite => 'Lax', # 20201203/NH : Cookie “DSID” will be soon rejected because it has the “sameSite” attribute set to “none” or an invalid value, without the “secure” attribute. To know more about the “sameSite“ attribute, read https://developer.mozilla.org/docs/Web/HTTP/Headers/Set-Cookie/SameSite
            # 20210617/NH : le retour de ws.colissimo.fr vers jle5, en POST depuis l'origine externe, omet le cookie si on n'a que "sameSite: Lax"... httpOnly fait en sorte que Javascript ne puisse pas accéder au cookie de session, ce qui est plus sûr...
            #   En pratique, on doit dans ce cas conserver la valeur SameSite=None, donc forcément avoir Secure (et donc accès au site jle5 via HTTPS)
            -httponly => 1, # 20210622/NH : le cookie de session n'est en pratique pas utilisé en dehors des requêtes HTTP(S), et ne doit donc JAMAIS être accessible via Javascript, source de problèmes XSS
            -secure => ($r->headers_in->get('X-Forwarded-Proto') eq 'https'), # 20210622/NH : si le site est en HTTPS, alors on marque le cookie comme "Secure", ce qui fait que le navigateur ne le renverra qu'en HTTPS, ce qui fait que le cookie n'existe en apparence pas en HTTP
        );
        $cookie->expires($expires) unless ($expires eq 'memory');

        # On place le cookie même en cas d'erreur (redirect, etc)
        $r->err_headers_out->{'Set-Cookie'} = $cookie;
    }

    # Create the Application Server Object GHS::AppServ
    $HTML::Mason::Commands::app = new GHS::AppServ(\%HTML::Mason::Commands::session, $HTML::Mason::Commands::dbh);

    eval {
        # In order to avoid executions warnings, but inside components only
        #use common::sense;
        #no warnings;
        # Add a stage-specific Perl client-lib base directory. @INC will be restored after this block.
        # Loaded modules will anyway stay in memory, whatever they originate from: don't mix names between clients!
        local @INC = @INC;
        unshift(@INC, dirname($r->dir_config('SHAREDDIR')).'/lib/perl');

        # Select the handler dedicated to the stage we're handling
        my $mode = (exists($ah{$r->dir_config('MODE')}) ? $r->dir_config('MODE') : '_default_');
        $status = $ah{$mode}->handle_request($r);
    };
    if ($@) {
        $r->log_error($@);
    }

    # Log the login of the user in the Apache log.
    # Application may set '_login' session key to the actual name to magically populate the log file.
    $r->user( $HTML::Mason::Commands::session{'_login'} ) if ($HTML::Mason::Commands::session{'_session_id'} && $HTML::Mason::Commands::session{'_login'});

    untie %HTML::Mason::Commands::session; # Save the session contents to persistent storage
    undef %HTML::Mason::Commands::session; # Forget the value in memory (may help reduce memory leak)
    $HTML::Mason::Commands::dbh->disconnect if ($HTML::Mason::Commands::dbh);
    undef $HTML::Mason::Commands::dbh;
    undef $HTML::Mason::Commands::app;

    return $status;
}

# Convert arguments passed from the browser to UTF8, for all virtualhosts
# http://www.cybaea.net/Journal/2009/01/28/4-easy-steps-to-make-Mason-utf-8-Unicode-clean/
package MasonX::Plugin::UTF8;
use base qw(HTML::Mason::Plugin);
use common::sense;
sub start_request_hook {
    my ($self, $context) = @_;
    foreach my $arg (@{$context->args()}) {
        if (not ref($arg)) { # single args are plain scalars
            utf8::decode($arg) unless utf8::is_utf8($arg);
        } elsif (ref($arg) eq 'ARRAY') { # multiple same-name args are stored as arrays
            map { utf8::decode($_) unless utf8::is_utf8($_); } @$arg;
        }
    }
    return;
}

# Nota : this above info does not say that preamble do NOT read "once" sections as UTF-8.
# To do also that (if static strings are defined in "once"), you must add a "use utf8;" in "once" sections, or hack
# /usr/share/perl5/HTML/Mason/Compiler/ToObject.pm
#   306     return join '', ( "package $pkg;\n",
#   307                       # 20180911/NH : properly encode in UTF8 even in the once sections
#   308                       #$self->use_strict ? "use strict;\n" : "no strict;\n",
#   309                       $self->use_strict ? "use common::sense;\n" : "no strict;\n",
#   310                       # 20180911/NH : end
#   311                       $self->use_warnings ? "use warnings;\n" : "",



1;

#=============================================================================
__END__
