227 lines
7.9 KiB
Perl
227 lines
7.9 KiB
Perl
# 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/@/@/g;
|
|
# Decode the e-mail at-signs (@) of spamtrap
|
|
$html =~ s/spamtrap@/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;
|