X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=d2878f6afc9f25af7f7e5a76b5eadef60421b32e;hb=c7c9eaea7e0999f214679286f1fa103dc70681c1;hp=cabea9d6f7f0f22cc9600ff87a0fd9ce1df8902e;hpb=bf10251dee0cba6ce3ca3504edb6bb805d003cbd;p=MyWeb.git

diff --git a/Web.pm b/Web.pm
index cabea9d..d2878f6 100644
--- a/Web.pm
+++ b/Web.pm
@@ -143,15 +143,20 @@ my($class,%args)=@_;
 	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 { 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();
@@ -265,35 +270,51 @@ my($class,%args)=@_;
 
 	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;
 }
 
 # 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}(@_);
+	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
 {
+	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;
+	# Prevent: Subroutine CORE::GLOBAL::exit redefined
+	no warnings 'redefine';
+	*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;
@@ -494,8 +515,8 @@ my($msg)=@_;
 
 sub footer()
 {
-	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;
@@ -674,6 +695,7 @@ my($self,$url,$status)=@_;
 	$W->{"r"}->status($status);
 	$W->{"r"}->headers_out()->{"Location"}=$url;
 	$W->{"header_only"}=1;
+	$W->{"content_type"}=0;
 	My::Web->heading();
 	exit;
 	die "NOTREACHED";
@@ -1070,20 +1092,18 @@ my($class)=@_;
 	# 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
@@ -1094,14 +1114,14 @@ my($class)=@_;
 					"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 ?
@@ -1109,17 +1129,24 @@ my($class)=@_;
 			]);
 	# 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") && (0
+					|| $W->{"content_type"}=~m{^application/\w+[+]xml$}
+					|| $W->{"content_type"} eq "text/vnd.wap.wml");
 	return if $W->{"header_only"};
 	# Split 'heading_done' for the proper handling of: /project/Rel.pm
 	$W->{"heading_done"}++;