use Apache2::Connection;
require MIME::Base64;
use Apache2::ServerUtil;
+require MIME::Types;
#our $W;
# {"__PACKAGE__"} is mandatory for mod_perl-2.0;
# $Apache2::Registry::curstash is no longer supported.
do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";
+ exit_hook_start();
# See: &escapeHTML
do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset();
$W->{"headers_in"}=$W->{"headers_in_RecordKeys"};
}
- $W->{"browser"}=HTTP::BrowserDetect->new($W->{"headers_in"}{"User-Agent"});
+ $W->{"browser"}=sub {
+ # Lazy-evaluation, we may not need the "User-Agent" header at all.
+ return our $r||=HTTP::BrowserDetect->new($W->{"headers_in"}{"User-Agent"});
+ };
if (!defined $W->{"have_style"}) {
$W->{"have_style"}=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0);
# PerlResponseHandler is RUN_FIRST and &ModPerl::Util::exit returns OK, so no (sane) go.
# PerlLogHandler is already too late to be able to produce any output.
-my $exit_orig=\&CORE::GLOBAL::exit;
+my $exit_orig;
sub exit_hook
{
# &footer will call us recursively!
footer() if !$W->{"_exit_ran"}++;
return &{$exit_orig}(@_);
}
+sub exit_hook_start
{
+ cluck "exit_hook_start() twice?" if defined $exit_orig;
+ $exit_orig=\&CORE::GLOBAL::exit;
# Prevent: Subroutine CORE::GLOBAL::exit redefined
no warnings 'redefine';
*CORE::GLOBAL::exit=\&exit_hook;
- }
+}
+sub exit_hook_stop
+{
+ do { cluck "exit_hook_stop() without exit_hook_start()?"; return; }
+ if \&exit_hook ne \&CORE::GLOBAL::exit;
+ cluck "INTERNAL: exit_orig uninitialized" if !$exit_orig;
+ *CORE::GLOBAL::exit=$exit_orig;
+ $exit_orig=undef();
+}
# Be aware other parts of code (non-My::Web) will NOT use this function!
# Do not: Wprint $W->{"heading"},"undef"=>1;
sub footer()
{
+ exit_hook_stop();
cluck 'Explicit &footer call is deprecated' if !$W->{"_exit_ran"};
exit if $W->{"footer_passed"}++; # deadlock prevention:
+ if ($W->{"header_only"}) {
+ $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
+ exit;
+ }
Wprint vskip if $W->{"footer_delimit"};
&{$_}() for reverse @{$W->{"footing_delimit_sub_push"}};
}
last if OK==$status;
$W->{"r"}->status($status);
+ $W->{"header_only"}=1; # Inhibit &footer output.
exit;
die "NOTREACHED";
}
delete $Vary{$_};
}
%Vary=("*"=>1) if $Vary{"*"};
- $headers_out{"Vary"}=join(", ",sort keys(%Vary));
+ $headers_out{"Vary"}=join(", ",sort keys(%Vary)) if keys(%Vary);
# $W->{"r"}->set_last_modified() ?
$headers_out{"Last-Modified"}=cache_finish_last_modified();
# TODO: Support also: private
header("Cache-Control"=>"public"); # HTTP/1.1
- # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!)
- my $client_charset=$W->{"force_charset"} || "us-ascii";
+ # Use $W->{"force_charset"}=0 to disable charset.
+ my $client_charset=$W->{"force_charset"};
+ $client_charset="us-ascii" if !defined $client_charset;
# Workaround bug
# https://bugzilla.mozilla.org/show_bug.cgi?id=120556
# of at least
# Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217
- my $mime;
+ my $mime=$W->{"content_type"};
# http://validator.w3.org/ does not send ANY "Accept" headers!
- $mime||="application/xhtml+xml" if 1
+ $mime="application/xhtml+xml" if !$mime
&& !$W->{"headers_in"}{"Accept"}
&& ($W->{"headers_in"}{"User-Agent"}||"")=~m{^W3C_Validator/}i;
- $mime||=$class->Negotiate_choose([
+ $mime or $mime=$class->Negotiate_choose([
# Put the fallback variant as the first one.
# Rate both variants the same to prefer "text/html" for undecided clients.
# At least
]);
# mod_perl doc: If you set this header via the headers_out table directly, it
# will be ignored by Apache. So do not do that.
- $W->{"r"}->content_type("$mime; charset=$client_charset");
+ my $type=MIME::Types->new()->type($mime) if $client_charset;
+ cluck "MIME::Types type $mime not known" if $client_charset && !$type;
+ $client_charset=undef() if $type && !$type->isAscii();
+ $W->{"r"}->content_type($mime.(!$client_charset ? "" : "; charset=$client_charset"));
cache_start();
- return if $W->{"header_only"};
# We still can append headers before we put out some text.
# FIXME: It is not clean to still append them without overwriting.
- return if $W->{"heading_done"}++;
+ return if $W->{"heading_done"};
+ Wprint '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n"
+ if (!$W->{"header_only"} || $W->{"header_only"} eq "xml") && $mime=~m{^application/\w+[+]xml$};
+ return if $W->{"header_only"};
+ # Split 'heading_done' for the proper handling of: /project/Rel.pm
+ $W->{"heading_done"}++;
- Wprint '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n" if $mime=~m{^application/\w+[+]xml$};
- return if $W->{"xml_header_only"};
Wprint '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">'."\n";
Wprint '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="'.$W->{"language"}.'">'."\n";
my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ())));