Initial commit.
This commit is contained in:
226
lib/perl5/Selima/Destroy.pm
Normal file
226
lib/perl5/Selima/Destroy.pm
Normal file
@@ -0,0 +1,226 @@
|
||||
# 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;
|
||||
Reference in New Issue
Block a user