imacat/selima-perl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
main
selima-perl/lib/perl5/Selima/HTTP.pm
依瑪貓 78739bf725 Initial commit.
2026-03-10 21:31:43 +08:00

1628 lines
59 KiB
Perl
Raw Permalink Blame History

# Selima Website Content Management System
# HTTP.pm: The various HTTP status processors.
# Copyright (c) 2003-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: 2003-03-26
package Selima::HTTP;
use 5.008;
use strict;
use warnings;
use base qw(Exporter);
use vars qw(@EXPORT @EXPORT_OK);
BEGIN {
@EXPORT = qw();
push @EXPORT, qw(http_204 http_301 http_303 http_304 http_307);
push @EXPORT, qw(http_400 http_403 http_404 http_405 http_410 http_413 http_500 http_503);
@EXPORT_OK = @EXPORT;
# Prototype declaration
sub need_302();
sub get_custom_status_message($);
sub shall_mail_error();
sub http_204();
sub http_301($);
sub http_303($);
sub http_304();
sub http_307($);
sub http_400(;$);
sub http_403(;$);
sub http_404();
sub http_405(@);
sub http_410();
sub http_413();
sub http_500($);
sub http_503(;$);
}
use CGI qw(header);
use Encode qw(encode);
use HTTP::Date qw(time2str);
use IO::NestedCapture qw(CAPTURE_STDOUT);
BEGIN {
if (exists $ENV{"MOD_PERL_API_VERSION"} && $ENV{"MOD_PERL_API_VERSION"} >= 2) {
require Apache2::Connection;
require Apache2::Response;
}
}
use Selima::A2HTML;
use Selima::AbsURI;
use Selima::AltLang;
use Selima::DataVars qw(:env :input :l10n :lastmod :lninfo
:output :requri :siteconf);
use Selima::DecForm;
use Selima::Format;
use Selima::GeoIP;
use Selima::GetLang;
use Selima::Logging;
use Selima::LogIn;
use Selima::Page2Rel;
use Selima::PageFunc;
use Selima::ShortCut;
use Selima::Unicode;
use Selima::XFileIO;
use Selima::XHTML;
use Selima::Mail;
BEGIN {
# Only import this when mod_perl.
if ($IS_MODPERL) {
if ($IS_MP2) {
require Apache2::Const;
import Apache2::Const qw(:methods);
} else {
require Apache::Constants;
import Apache::Constants qw(:methods);
}
# Otherwise, set to dummy values to get around strict checking
} else {
require constant;
import constant M_OPTIONS => 0;
import constant M_GET => 0;
import constant M_HEAD => 0;
import constant M_POST => 0;
import constant M_PUT => 0;
import constant M_DELETE => 0;
import constant M_TRACE => 0;
import constant M_CONNECT => 0;
}
}
# need_302: Is this browser capable of HTTP 303 and HTTP 307?
# Currently only older Netscape without Gecko (version <= 4.xx)
# is known of this problem.
# Return:
# false: Standard behavior to send HTTP 303 or 307.
# true: Browser lacks the capability of redirecting
# HTTP 303 and 307. Send HTTP 302 instead.
sub need_302() {
local ($_, %_);
# User-Agent not sent, default to the standard behavior.
return 0 unless exists $ENV{"HTTP_USER_AGENT"};
$_ = $ENV{"HTTP_USER_AGENT"};
# Not Mozilla/Netscape series
return 0 unless /^Mozilla\//;
# Mozilla/Netscape compatible
return 0 if /\bcompatible\b/;
# Mozilla/Netscape with Gecko (version > 4)
return 0 if /\bGecko\b/;
# Mozilla/Netscape without Gecko (version <= 4)
return 1;
}
# get_custom_status_message: Obtain the custom status message
sub get_custom_status_message($) {
local ($_, %_);
my ($html, $status, $langfile, $charset);
$status = $_[0];
$langfile = getlang(LN_FILENAME);
# Find language specific error message first
if (-e ($_ = "$DOC_ROOT/errors/$status.html.$langfile.xhtml")) {
$html = xfread $_;
} elsif (-e ($_ = "$DOC_ROOT/errors/$status.html.$langfile")) {
$html = xfread $_;
} elsif (-e ($_ = "$DOC_ROOT/$langfile/errors/$status.html.xhtml")) {
$html = xfread $_;
} elsif (-e ($_ = "$DOC_ROOT/$langfile/errors/$status.html")) {
$html = xfread $_;
} elsif (-e ($_ = "$DOC_ROOT/errors/$status.html.xhtml")) {
$html = xfread $_;
} elsif (-e ($_ = "$DOC_ROOT/errors/$status.html")) {
$html = xfread $_;
}
# Not found
return if !defined $html;
# Reserve the character set
$charset = getlang(LN_CHARSET);
$html = hcref_decode($charset, $html);
$charset = h($charset);
$html =~ s/(?<=\bencoding=")$charset(?=")/<!--selima:charset-->/;
$html =~ s/(?<=\bcontent="text\/html; charset=)$charset(?=")/<!--selima:charset-->/;
$html =~ s/(?<=\bcontent="application\/xhtml\+xml; charset=)$charset(?=")/<!--selima:charset-->/;
$html =~ s/(?<=\btype="hidden" name="charset" value=")$charset(?=" \/>)/<!--selima:charset-->/g;
$html =~ s/(?<=\baccept-charset=")$charset(?=")/<!--selima:charset-->/g;
return $html;
}
# shall_mail_error: Should we mail the error to the webmaster
sub shall_mail_error() {
local ($_, %_);
# Return "no" if not CGI
return 0 if !$IS_CGI;
# Return "no" if inside our intranet
$_ = $IS_MODPERL? ($IS_MP2?
Apache2::RequestUtil->request->connection->remote_ip:
Apache->request->connection->remote_ip):
$ENV{"REMOTE_ADDR"};
return 0 if /^10\.0\.0\./ || $_ eq "127.0.0.1";
# Default to yes
return 1;
}
# http_204: HTTP/1.1 204 No Content
sub http_204() {
local ($_, %_);
my ($html, $r, $type, %h);
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Only output headers to the CGI interface
if ($IS_CGI) {
$type = defined $CONTENT_TYPE? $CONTENT_TYPE: xhtml_content_type;
# The mod_perl way
if ($IS_MODPERL) {
$r->status(204);
$r->headers_out->set("Content-Length"=>0);
$r->content_languages([getlang LN_NAME])
if $type =~ /^text\//;
# 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;
# Ordinary CGI
} else {
# Output the status message
%h = ( -status=>"204 No Content",
-Content_Length=>0);
$h{"-Content_Language"} = getlang LN_NAME
if $type =~ /^text\//;
# 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];
print header(%h);
}
}
# No need to return
exit;
}
# http_301: HTTP/1.1 301 Moved Permanently
sub http_301($) {
local ($_, %_);
my ($html, $r, $type, %h, $url);
$url = $_[0];
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Make URL absolute
$url = absuri $url;
# Obtain the status message
$html = get_custom_status_message(301);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>301 Moved Permanently</title>
</head>
<body>
<h1>301 Moved Permanently</h1>
<p>You should refer to <a href="\$url">the new location</a>.</p>
</body>
</html>
EOT
}
# Replace the page content
$html =~ s/\$url/h($url)/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(301, $html);
$r->status(301);
$r->err_headers_out->set("Location"=>$url);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"301 Moved Permanently",
-type=>$type,
-Location=>$url,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# No need to return
exit;
}
# http_303: HTTP/1.1 303 See Others
sub http_303($) {
local ($_, %_);
my ($html, $r, $type, %h, $url);
$url = $_[0];
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Make URL absolute
$url = absuri $url;
# Obtain the status message
$html = get_custom_status_message(303);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>303 See Others</title>
</head>
<body>
<h1>303 See Others</h1>
<p>Please follow <a href="\$url">this location</a>.</p>
</body>
</html>
EOT
}
# Replace the page content
$html =~ s/\$url/h($url)/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
if (need_302) {
$r->custom_response(302, $html);
$r->status(302);
} else {
$r->custom_response(303, $html);
$r->status(303);
}
$r->err_headers_out->set("Location"=>$url);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"303 See Others",
-type=>$type,
-Location=>$url,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $html);
$h{"-status"} = "302 Found" if need_302;
# 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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# No need to return
exit;
}
# http_304: HTTP/1.1 304 Not Modified
sub http_304() {
local ($_, %_);
my ($html, $r, $type, %h);
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Only output headers to the CGI interface
# See HTTP/1.1 sec 10.3.5 for appropriate headers to send
if ($IS_CGI) {
# The mod_perl way
# We must do it in the mod_perl way, since the CGI.pm sends an
# excess line break under mod_perl, which breaks the HTTP/304
# response for the browser.
if ($IS_MODPERL) {
$r->status(304);
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# We must send them
$r->err_headers_out->set("Content-Location"=>altlang(getlang, page_param))
if @ALL_LINGUAS > 1;
# Ordinary CGI
} else {
$type = (defined $CONTENT_TYPE? $CONTENT_TYPE: xhtml_content_type)
. "; charset=" . getlang(LN_CHARSET);
# Output the status message
%h = ( -status=>"304 Not Modified");
$h{"-Content_Location"} = altlang getlang, page_param
if @ALL_LINGUAS > 1;
# Avoid the bug of Apache/CGI that always send the content type
# even with HTTP/304
$h{"-type"} = $type;
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# No need to return
exit;
}
# http_307: HTTP/1.1 307 Temporary Redirect
sub http_307($) {
local ($_, %_);
my ($html, $r, $type, %h, $url);
$url = $_[0];
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Make URL absolute
$url = absuri $url;
# Obtain the status message
$html = get_custom_status_message(307);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>307 Temporary Redirect</title>
</head>
<body>
<h1>307 Temporary Redirect</h1>
<p>Please refer to <a href="\$url">the following location</a>.</p>
</body>
</html>
EOT
}
# Replace the page content
$html =~ s/\$url/h($url)/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
if (need_302) {
$r->custom_response(302, $html);
$r->status(302);
} else {
$r->custom_response(307, $html);
$r->status(307);
}
$r->err_headers_out->set("Location"=>$url);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"307 Temporary Redirect",
-type=>$type,
-Location=>$url,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $html);
$h{"-status"} = "302 Found" if need_302;
# 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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# No need to return
exit;
}
# http_400: HTTP/1.1 400 Bad Request
# 0 to disable error page output
sub http_400(;$) {
local ($_, %_);
my ($html, $r, $type, %h);
my $errmsg;
$errmsg = $_[0];
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Obtain the status message
$html = get_custom_status_message(400)
unless defined $errmsg && $errmsg eq "0";
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>400 Bad Request</title>
</head>
<body>
<h1>400 Bad Request</h1>
<!-- errmsg -->
<p>Sorry, the server cannot understand what you are asking for.</p>
</body>
</html>
EOT
}
# Replace the page content
$html =~ s/<!-- errmsg -->/defined $errmsg && $errmsg ne "0"?
"<p>" . h(F_($errmsg)) . "<\/p>": ""/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(400, $html);
$r->status(400);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"400 Bad Request",
-type=>$type,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Log the error message to the server error log
if (!defined $errmsg) {
log_error "Bad Request: $REQUEST_URI";
} elsif ($errmsg eq "0") {
if ($IS_MODPERL) {
$_ = $r->the_request;
} else {
$_ = $ENV{"REQUEST_METHOD"} . " "
. $ENV{"REQUEST_URI"} . " " . $ENV{"SERVER_PROTOCOL"};
}
log_error "Invalid URI in request $_";
} else {
log_error "Bad Request: $REQUEST_URI: $errmsg";
}
# No need to return
exit 400 if !$IS_CGI;
exit;
}
# http_403: HTTP/1.1 403 Forbidden
sub http_403(;$) {
local ($_, %_);
my ($html, $r, $type, %h);
my $errmsg;
$errmsg = $_[0];
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Obtain the status message
$html = get_custom_status_message(403)
unless defined $errmsg && $errmsg eq "0";
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>403 Forbidden</title>
</head>
<body>
<h1>403 Forbidden</h1>
<!-- errmsg -->
<p>You are not allowed to enter here.</p>
</body>
</html>
EOT
}
# Replace the page content
$html =~ s/<!-- errmsg -->/defined $errmsg && $errmsg ne "0"?
"<p>" . h(F_($errmsg)) . "<\/p>": ""/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(403, $html);
$r->status(403);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"403 Forbidden",
-type=>$type,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Log the error message to the server error log
if (!defined $errmsg) {
log_error "Forbidden: $REQUEST_URI";
} elsif ($errmsg eq "0") {
if ($IS_MODPERL) {
$_ = $r->the_request;
} else {
$_ = $ENV{"REQUEST_METHOD"} . " "
. $ENV{"REQUEST_URI"} . " " . $ENV{"SERVER_PROTOCOL"};
}
log_error "Suspicious bad robot: $_";
} else {
log_error "Forbidden: $REQUEST_URI: $errmsg";
}
# No need to return
exit 403 if !$IS_CGI;
exit;
}
# http_404: HTTP/1.1 404 Not Found
sub http_404() {
local ($_, %_);
my ($html, $r, $type, %h);
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Obtain the status message
$html = get_custom_status_message(404);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>404 Not Found</title>
</head>
<body>
<h1>404 Not Found</h1>
<p>The document you requested was not found.</p>
</body>
</html>
EOT
}
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(404, $html);
$r->status(404);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"404 Not Found",
-type=>$type,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Log the error message to the server error log
log_error "Not Found: $REQUEST_URI";
# No need to return
exit 404 if !$IS_CGI;
exit;
}
# http_405: HTTP/1.1 405 Method Not Allowed
sub http_405(@) {
local ($_, %_);
my ($html, $r, $type, %h, @allowed);
@allowed = @_;
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Obtain the status message
$html = get_custom_status_message(405);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>405 Method Not Allowed</title>
</head>
<body>
<h1>405 Method Not Allowed</h1>
<p>You should use the following methods: \$allowed.</p>
</body>
</html>
EOT
}
# Replace the page content
$html =~ s/\$allowed/join(", ", map "<samp>" . h($_) . "<\/samp>", @allowed)/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
my $allowed_b;
$allowed_b = 0;
foreach (@allowed) {
if ($_ eq "OPTIONS") {
$allowed_b |= (1 << M_OPTIONS);
} elsif ($_ eq "GET") {
$allowed_b |= (1 << M_GET);
# M_HEAD is not defined in Apache. It is implied by M_GET.
#} elsif ($_ eq "HEAD") {
# $allowed_b |= (1 << M_HEAD);
} elsif ($_ eq "POST") {
$allowed_b |= (1 << M_POST);
} elsif ($_ eq "PUT") {
$allowed_b |= (1 << M_PUT);
} elsif ($_ eq "DELETE") {
$allowed_b |= (1 << M_DELETE);
} elsif ($_ eq "TRACE") {
$allowed_b |= (1 << M_TRACE);
} elsif ($_ eq "CONNECT") {
$allowed_b |= (1 << M_CONNECT);
}
}
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(405, $html);
$r->status(405);
$r->allowed($allowed_b);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"405 Method Not Allowed",
-type=>$type,
-Allow=>join(", ", @allowed),
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Log the error message to the server error log
$_ = $IS_MODPERL? $r->method: $ENV{"REQUEST_METHOD"};
log_error "$_: Method Not Allowed (" . join(", ", @allowed) . "): $REQUEST_URI\n";
# No need to return
exit 405 if !$IS_CGI;
exit;
}
# http_410: HTTP 410 Gone
sub http_410() {
local ($_, %_);
my ($html, $r, $type, %h);
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Obtain the status message
$html = get_custom_status_message(410);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>410 Gone</title>
</head>
<body>
<h1>410 Gone</h1>
<p>Sorry, this page is removed permanently, and there is no forwarding address available. Please remove your bookmarks, and stop referring to this page any more. Thanks.</p>
</body>
</html>
EOT
}
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(410, $html);
$r->status(410);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"410 Gone",
-type=>$type,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Log the error message to the server error log
log_error "Gone: $REQUEST_URI";
# No need to return
exit 410 if !$IS_CGI;
exit;
}
# http_413: HTTP/1.1 413 Request Entity Too Large
sub http_413() {
local ($_, %_);
my ($html, $r, $type, %h);
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Obtain the status message
$html = get_custom_status_message(413);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>413 Request Entity Too Large</title>
</head>
<body>
<h1>413 Request Entity Too Large</h1>
<p>The server refuses to process your large submitted data.</p>
</body>
</html>
EOT
}
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(413, $html);
$r->status(413);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"413 Request Entity Too Large",
-type=>$type,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Log the error message to the server error log
log_error "Request Entity Too Large: $REQUEST_URI";
# No need to return
exit 413 if !$IS_CGI;
exit;
}
# http_500: HTTP/1.1 500 Internet Server Error
sub http_500($) {
local ($_, %_);
my ($html, $r, $type, %h);
my ($errmsg, @callers, $remote);
$errmsg = $_[0];
# Find out our context
for (my $i = 0, @callers = qw(); (@_ = caller $i) > 0; $i++) {
# Avoid recursive calls
# Not possible. $SIG{"__DIE__"} is disabled during itself.
# Context after Apache::Registry is not meaningful
last if $_[1] =~ /\/Apache\/Registry\.pm$/;
# Skip if in eval().
# Apache handler() eval() is not trapped for it is at Apache::Registry
# and is skipped by the above rule.
return if $_[3] eq "(eval)";
push @callers, [@_];
}
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
$remote = $IS_MODPERL? $r->connection->remote_ip:
$ENV{"REMOTE_ADDR"};
# Variables in the status message
$errmsg =~ s/ at \S+ line \d+\.\n//;
# Obtain the status message
$html = get_custom_status_message(500);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>500 Internel Server Error</title>
</head>
<body>
<h1>500 Internel Server Error</h1>
<!-- errmsg -->
</div>
</body>
</html>
</html>
EOT
}
# Replace the page content
$html =~ s/<!-- errmsg -->/
"<div class=\"errmsg\">\n<samp>" . a2html($errmsg) . "<\/samp><br \/>\n"
. join("<br \/>\n", map "at <samp>" . h($$_[1]) . "<\/samp> line " . h($$_[2]), @callers)
. ".\n<\/div>"/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(500, $html);
$r->status(500);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"500 Internel Server Error",
-type=>$type,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Mail the webmaster on this error
if (shall_mail_error) {
my ($mail, $webmaster, $site, $body, $reqline, $reqhdrs, $form);
# Get the webmaster address to notify to
if (defined $WEBMASTER) {
$webmaster = $WEBMASTER;
} elsif (exists $ENV{"SERVER_ADMIN"}) {
$webmaster = $ENV{"SERVER_ADMIN"};
} else {
$webmaster = "webmaster\@" . $ENV{"SERVER_NAME"};
}
# Get the site name
$site = defined $SITENAME_ABBR? $SITENAME_ABBR:
defined $PACKAGE? $PACKAGE: $REQUEST_HOST;
# The request string
if ($IS_MODPERL) {
$r->as_string =~ /^([^\n]+)\n((?:[^\n]+\n)*).+?$/s;
($reqline, $reqhdrs) = ($1, $2);
$reqhdrs =~ s/^(.+)$/* $1/gm;
} else {
$reqline = sprintf "%s %s%s %s",
$ENV{"REQUEST_METHOD"}, $ROOT_DIFF, $REQUEST_URI,
$ENV{"SERVER_PROTOCOL"};
%_ = qw();
foreach my $key (grep /^HTTP_/, keys %ENV) {
$_ = $key;
s/^HTTP_//;
s/_/-/g;
s/(\w)(\w+)/$1 . lc $2/ge;
$_{$_} = $ENV{$key};
}
$reqhdrs = join "", map "* $_: $_{$_}\n", sort keys %_;
}
$body = "";
# Basic information
$_ = << "EOT";
[%s] HTTP 500 Server Error Report %s
==============================
* Time: %s
* URI: %s
* Request: %s
* Error Message:
%s
%s.
EOT
$body = sprintf $_, $site, fmtdate,
fmttime, $REQUEST_FULLURI, $reqline,
$errmsg, join("\n", map " at $$_[1] line $$_[2]", @callers);
# Client headers
$body .= "Client Headers:\n$reqhdrs\n";
# POSTed form
if (($IS_MODPERL? $r->method: $ENV{"REQUEST_METHOD"}) eq "POST") {
$body .= "POST form:\n";
if (exists $USER_INPUT{"POST_RAW"}) {
$form = $USER_INPUT{"POST_RAW"};
} else {
$form = new CGI;
}
$body .= join "", map "* $_: " . $form->param($_) . "\n",
sort $form->param;
$body .= "\n";
}
# CGI metavariables - refer to CGI 1.1
@_ = qw(AUTH_TYPE CONTENT_LENGTH CONTENT_TYPE GATEWAY_INTERFACE
PATH_INFO PATH_TRANSLATED QUERY_STRING REMOTE_ADDR REMOTE_HOST
REMOTE_IDENT REMOTE_USER REQUEST_METHOD SCRIPT_NAME SERVER_PORT
SERVER_PROTOCOL SERVER_SOFTWARE);
$body .= "CGI Metavariables:\n";
$body .= join "", map "* $_: $ENV{$_}\n", grep exists $ENV{$_}, @_;
$body .= "\n";
# Other information
$body .= "Other information:\n";
if (defined get_login_sn) {
$_ = "";
$_ .= "* User ID.: " . get_login_id . "\n";
$_ .= "* User name: " . get_login_name . "\n";
$_ .= "* User S/N: " . get_login_sn . "\n";
$_ .= "* User groups: " . join(" ", get_login_groups) . "\n";
$body .= encode("UTF-8", $_);
} else {
$body .= "* User ID.: (not logged in)\n";
}
$body .= "* Client country: " . country_lookup . "\n";
$body .= "\n";
# Compose and send the mail
$mail = new Selima::Mail;
$mail->from("HTTP.pm\@" . $ENV{"SERVER_NAME"}, "$site Website");
$mail->to($webmaster, "$site Webmaster");
$mail->subject(sprintf("[%s] HTTP 500 Server Error Report %s", $site, fmtdate));
$mail->body($body);
$mail->send;
}
# Log the error message to the server error log
log_error("$errmsg " . join(" ", map "at $$_[1] line $$_[2]", @callers) . ".");
# No need to return
exit 500 if !$IS_CGI;
exit;
}
# http_503: HTTP/1.1 503 Service Unavailable
sub http_503(;$) {
local ($_, %_);
my ($html, $r, $type, %h);
my $errmsg;
$errmsg = $_[0];
# Obtain the Apache mod_perl request
$r = $IS_MP2? Apache2::RequestUtil->request: Apache->request
if $IS_MODPERL;
# Clear the STDOUT buffer
IO::NestedCapture->stop(CAPTURE_STDOUT)
while exists IO::NestedCapture->instance->{"STDOUT_current"}
&& @{IO::NestedCapture->instance->{"STDOUT_current"}} > 0;
# Skip content auto-output
$NO_AUTO_OUTPUT = 1;
# Obtain the status message
$html = get_custom_status_message(503);
# Fall back to a simplest default
if (!defined $html) {
$html = << "EOT";
<?xml version="1.0" encoding="US-ASCII" ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
<head>
<title>503 Service Unavailable</title>
</head>
<body>
<h1>503 Service Unavailable</h1>
<!-- errmsg -->
<p>Sorry, our service is currently not available. Please come back later.</p>
</body>
</html>
EOT
}
# Replace the page content
$html =~ s/<!-- errmsg -->/defined $errmsg? "<p>" . h($errmsg) . "<\/p>": ""/ge;
# 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;
# Only output headers to the CGI interface
if ($IS_CGI) {
# The mod_perl way
if ($IS_MODPERL) {
# Error documents can only be output as ISO-8859-1 under mod_perl.
# It is hardcoded into Apache http_protocol.c ap_send_error_response().
# See http://www.geocrawler.com/mail/msg.php3?msg_id=6288656
$html = page_encode($html, "ISO-8859-1");
$r->custom_response(503, $html);
$r->status(503);
$r->err_headers_out->set("Content-Language"=>getlang LN_NAME);
$r->err_headers_out->set("Content-Length"=>length $html);
# 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->err_headers_out->set("Content-Location"=>altlang(getlang, page_param));
$r->err_headers_out->set("Vary"=>"accept-language,cookie");
}
$r->err_headers_out->add("Set-Cookie"=>$_)
foreach values %NEWCOOKIES;
# Ordinary CGI
} else {
$html = page_encode($html, getlang(LN_CHARSET));
$type = xhtml_content_type . "; charset=" . getlang(LN_CHARSET);
%h = ( -status=>"503 Service Unavailable",
-type=>$type,
-Content_Language=>getlang(LN_NAME),
-Content_Length=>length $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";
}
$h{"-cookie"} = [values %NEWCOOKIES];
print header(%h);
print $html if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Output the content directly as a console application
} else {
print page_encode($html, getlang(LN_CHARSET))
if $ENV{"REQUEST_METHOD"} ne "HEAD";
}
# Log the error message to the server error log
# No logging due to maintainance
# No need to return
exit 503 if !$IS_CGI;
exit;
}
return 1;
Reference in New Issue View Git Blame Copy Permalink