Wuse 'WebConfig';
Wrequire 'My::Hash';
- $W=My::Hash->new({
+ # $W={} can get somehow created very easily.
+ cluck "W not empty:\n".Dumper($W) if keys(%$W);
+ $W=bless My::Hash->new({}),$class;
+ $W=My::Hash->new($W,"My::Hash::Sub","My::Hash::Push");
+ %$W=(
"__PACKAGE__"=>scalar(caller()),
%WebConfig,
%args, # override %WebConfig settings
- },"My::Hash::Sub","My::Hash::Push");
+ );
# {"__PACKAGE__"} is mandatory for mod_perl-2.0;
# $Apache2::Registry::curstash is no longer supported.
do { _args_check(%$_) if $_; } for ($W->{"args_check"});
- return bless $W,$class;
+ $W->{"_init_done"}=1;
+ return $W;
}
sub cleanup($)
{
my($apache_request)=@_;
- cluck "CORE::GLOBAL::exit hook not ran" if !$W->{"_exit_ran"};
+ cluck "CORE::GLOBAL::exit hook not ran" if !$W->{"_exit_done"};
cluck "packages not finalized" if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"};
cache_finish();
# Sanity protection.
$W=undef();
+ exit_hook_stop();
return OK;
}
my $exit_orig;
sub exit_hook
{
- # &footer will call us recursively!
- footer() if !$W->{"_exit_ran"}++;
- return &{$exit_orig}(@_);
+ cluck "Missing ->init while in exit_hook()" if !$W->{"_init_done"};
+ # &footer will call us recursively!
+ footer() if !$W->{"_exit_done"}++;
+ return &{$exit_orig}(@_);
}
sub exit_hook_start
{
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;
+ # Prevent: Subroutine CORE::GLOBAL::exit redefined
+ no warnings 'redefine';
*CORE::GLOBAL::exit=$exit_orig;
$exit_orig=undef();
}
sub footer()
{
- exit_hook_stop();
- cluck 'Explicit &footer call is deprecated' if !$W->{"_exit_ran"};
- exit if $W->{"footer_passed"}++; # deadlock prevention:
+ cluck 'Explicit &footer call is deprecated, !_exit_dne' if !$W->{"_exit_done"};
+ exit if $W->{"footer_done"}++; # deadlock prevention:
if ($W->{"header_only"}) {
$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
exit;
$W->{"r"}->status($status);
$W->{"r"}->headers_out()->{"Location"}=$url;
$W->{"header_only"}=1;
+ $W->{"content_type"}=0;
My::Web->heading();
exit;
die "NOTREACHED";
# TODO: Support also: private
header("Cache-Control"=>"public"); # HTTP/1.1
- # Use $W->{"force_charset"}=0 to disable charset.
- my $client_charset=$W->{"force_charset"};
- $client_charset="us-ascii" if !defined $client_charset;
+ # Use $W->{"charset"}=0 to disable charset.
+ $W->{"charset"}="us-ascii" if !defined $W->{"charset"} && !defined($W->{"content_type"}) || $W->{"content_type"};
# 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=$W->{"content_type"};
# http://validator.w3.org/ does not send ANY "Accept" headers!
- $mime="application/xhtml+xml" if !$mime
+ $W->{"content_type"}="application/xhtml+xml" if !defined $W->{"content_type"}
&& !$W->{"headers_in"}{"Accept"}
&& ($W->{"headers_in"}{"User-Agent"}||"")=~m{^W3C_Validator/}i;
- $mime or $mime=$class->Negotiate_choose([
+ defined($W->{"content_type"}) or $W->{"content_type"}=$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
"id"=>"text/html",
"content-type"=>"text/html",
"qs"=>0.6,
- "charset"=>$client_charset,
+ (!$W->{"charset"} ? () : "charset"=>$W->{"charset"}),
"lang"=>$W->{"language"},
),
negotiate_variant(
"id"=>"application/xhtml+xml",
"content-type"=>"application/xhtml+xml",
"qs"=>0.6,
- "charset"=>$client_charset,
+ (!$W->{"charset"} ? () : "charset"=>$W->{"charset"}),
"lang"=>$W->{"language"},
),
# application/xml ?
]);
# 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.
- 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"));
+ my $type;
+ if ($W->{"content_type"}) {
+ $type=MIME::Types->new()->type($W->{"content_type"});
+ cluck "MIME::Types type '".$W->{"content_type"}."' not known" if !$type;
+ }
+ cluck "charset='".$W->{"charset"}."' does not match content-type='".$W->{"content_type"}."'"
+ if ($W->{"charset"} ? 1 : 0) != (!$type ? 0 : $type->isAscii());
+ $W->{"r"}->content_type($W->{"content_type"}.(!$W->{"charset"} ? "" : "; charset=".$W->{"charset"}))
+ if $W->{"content_type"};
cache_start();
# 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"};
- Wprint '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n"
- if (!$W->{"header_only"} || $W->{"header_only"} eq "xml") && $mime=~m{^application/\w+[+]xml$};
+ Wprint '<?xml version="1.0" encoding="'.$W->{"charset"}.'"?>'."\n"
+ if (!$W->{"header_only"} || $W->{"header_only"} eq "xml") && $W->{"content_type"}=~m{^application/\w+[+]xml$};
return if $W->{"header_only"};
# Split 'heading_done' for the proper handling of: /project/Rel.pm
$W->{"heading_done"}++;