# Selima Website Content Management System
# Destroy.pm: The script-environment cleaner.

#  Copyright (c) 2004-2018 imacat.
#
#  Licensed under the Apache License, Version 2.0 (the "License");
#  you may not use this file except in compliance with the License.
#  You may obtain a copy of the License at
#
#      http://www.apache.org/licenses/LICENSE-2.0
#
#  Unless required by applicable law or agreed to in writing, software
#  distributed under the License is distributed on an "AS IS" BASIS,
#  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#  See the License for the specific language governing permissions and
#  limitations under the License.

# Author: imacat <imacat@mail.imacat.idv.tw>
# First written: 2004-09-27

package Selima::Destroy;
use 5.008;
use strict;
use warnings;

use CGI qw(header);
use HTTP::Date qw(time2str);
use IO::NestedCapture qw(CAPTURE_STDOUT);
use Time::HiRes qw();

BEGIN {
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
    require Apache2::Response;
}
}

use Selima::AltLang;
use Selima::Cache qw();
use Selima::DataVars qw($DBH $SESSION :env :input :l10n :lastmod
    :lninfo :output :proctime :requri :scptconf :siteconf);
use Selima::GetLang;
use Selima::HTTP;
use Selima::Logging;
use Selima::LogIn;
use Selima::Page2Rel;
use Selima::PageFunc;
use Selima::Unicode;
use Selima::XHTML;

# new: Initialize the object
sub new : method { bless {}, $_[0]; }

# DESTROY: Clean all the variables
sub DESTROY : method {
    local ($_, %_);
    my ($self, $html);
    $self = $_[0];
    
    # Disconnect the database handle
    if (defined $DBH) {
        $DBH->disconnect;
        undef $DBH;
    }
    
    # Flush, close and release the session and its lock
    if (defined $SESSION) {
        $SESSION->close;
        undef $SESSION;
    }
    
    # Output the content
    if (!$NO_AUTO_OUTPUT) {
        my ($type, $r, $charset, $is_html, $is_text);
        
        # Obtain the output
        $html = "";
        while ( exists IO::NestedCapture->instance->{"STDOUT_current"}
                && @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0) {
            my $FD;
            IO::NestedCapture->stop(CAPTURE_STDOUT);
            $FD = IO::NestedCapture->get_last_out;
            $html .= join "", <$FD>;
        }
        
        # No content -- HTTP 204
        http_204 if $html eq "";
        
        $type = defined $CONTENT_TYPE? $CONTENT_TYPE: xhtml_content_type;
        $is_html = ($type =~ /^(?:text\/html|application\/xhtml\+xml)\b/)? 1: 0;
        $is_text = ($type =~ /^(?:text\/plain|text\/csv)\b/)? 1: 0;
        
        # Do the run-time replacements
        if (    ($is_text || $is_html)
                && defined($_ = $MAIN->can("page_replacements"))) {
            %_ = %{&$_};
            $html =~ s/<!--selima:$_-->/${$_{$_}}{"content"}/g
                foreach keys %_;
        }
        
        # Fix the HTML output
        if ($is_html) {
            if ($type =~ /; charset=([^ ;]+)/) {
                $charset = $1;
            } else {
                $charset = getlang(LN_CHARSET);
                $type .= "; charset=$charset";
            }
            # Convert the URLs to relative
            $html = page2rel($html, $REQUEST_PATH);
            # Encode the e-mail at-signs (@)
            $html =~ s/@/&#64;/g;
            # Decode the e-mail at-signs (@) of spamtrap
            $html =~ s/spamtrap&#64;/spamtrap@/g;
            # Convert to the desired character set
            $html = page_encode($html, $charset);
        
        # Fix the plain text output
        } elsif ($is_text) {
            if ($type =~ /; charset=([^ ;]+)/) {
                $charset = $1;
            } else {
                $charset = "UTF-8";
                $type .= "; charset=$charset";
            }
            # Encode the e-mail at-signs (@)
            $html =~ s/@/-at-/g;
            # Decode the e-mail at-signs (@) of spamtrap
            $html =~ s/spamtrap-at-/spamtrap@/g;
            # Convert to the desired character set
            $html = page_encode($html, $charset);
        }
        
        # Only output headers to CGI
        if ($IS_CGI) {
            # The mod_perl way
            if ($IS_MODPERL) {
                $r = $IS_MP2? Apache2::RequestUtil->request:
                    Apache->request;
                $r->content_type($type);
                if ($IS_MP2) {
                    $r->set_content_length(length $html);
                } else {
                    $r->headers_out->set("Content-Length"=>length $html);
                }
                $r->headers_out->set("Accept-Ranges"=>"none");
                $r->content_languages([getlang LN_NAME])
                    if $type =~ /^text\// || $is_html;
                # Client cache
                if (defined $LAST_MODIFIED) {
                    if (defined get_login_sn) {
                        $r->headers_out->set("Cache-Control"=>"private");
                    } else {
                        $r->headers_out->set("Cache-Control"=>"public");
                    }
                    $r->headers_out->set("Last-Modified"=>time2str($LAST_MODIFIED));
                } else {
                    $r->headers_out->set("Cache-Control"=>"no-cache");
                }
                # Content negotiation, see HTTP/1.1 section 13.6
                if (    @ALL_LINGUAS > 1
                        && $r->method ne "POST"
                        && $r->method ne "PUT"
                        && !defined $GET->param("lang")) {
                    $r->headers_out->set("Content-Location"=>altlang(getlang, page_param));
                    $r->headers_out->set("Vary"=>"accept-language,cookie");
                }
                $r->headers_out->add("Set-Cookie"=>$_)
                    foreach values %NEWCOOKIES;
                $r->headers_out->add($_=>$HTTP_HEADERS{$_})
                    foreach keys %HTTP_HEADERS;
                $r->send_http_header if !$IS_MP2;
            
            # Ordinary CGI
            } else {
                my %h;
                %h = (  -type=>$type,
                        -Content_Length=>length $html,
                        -Accept_Ranges=>"none");
                $h{"-Content_Language"} = getlang LN_NAME
                    if $type =~ /^text\// || $is_html;
                # Content negotiation, see HTTP/1.1 section 13.6
                if (    @ALL_LINGUAS > 1
                        && $ENV{"REQUEST_METHOD"} ne "POST"
                        && $ENV{"REQUEST_METHOD"} ne "PUT"
                        && !defined $GET->param("lang")) {
                    $h{"-Content_Location"} = altlang getlang, page_param;
                    $h{"-Vary"} = "accept-language,cookie";
                }
                # Client cache
                if (defined $LAST_MODIFIED) {
                    if (defined get_login_sn) {
                        $h{"-Cache_Control"} = "private";
                    } else {
                        $h{"-Cache_Control"} = "public";
                    }
                    $h{"-Last_Modified"} = time2str($LAST_MODIFIED);
                } else {
                    $h{"-Cache_Control"} = "no-cache";
                }
                $h{"-cookie"} = [values %NEWCOOKIES];
                $h{$_} = $HTTP_HEADERS{$_} foreach keys %HTTP_HEADERS;
                print header(%h);
            }
        }
        # Print the page body
        print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
    }
    
    # Print the processing time for debugging purpose
    log_warn "Process time: " . (Time::HiRes::time - $T_START) . " sec.\n"
        if $LOGTIME;
    
    # Clear the data variables
    $_ = "Selima::" . $PACKAGE . "::Config";
    &$_ if defined($_ = $_->can("clear"));
    Selima::DataVars::clear;
    # Clear the cache
    Selima::Cache::clear;
    
    # Run the parent DESTROY method
    $self->SUPER::DESTROY if $self->can("SUPER::DESTROY");
    # I cannot really undefine myself ($_[0]) after all
    return;
}

return 1;