X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=dbb9c44a06add15277326c27777d1f19b7ad4bf4;hb=4e6161858714cf6b06278b32e36df915ef81c6fc;hp=3eb176bc1d93e748ad4971464830e55dbc3ae8cc;hpb=3f4bb50b019115eb59282928c7eea99c3d2a7b2d;p=MyWeb.git

diff --git a/Web.pm b/Web.pm
index 3eb176b..dbb9c44 100644
--- a/Web.pm
+++ b/Web.pm
@@ -31,14 +31,18 @@ our @EXPORT=qw(
 		&Wrequire &Wuse
 		&path_web &path_abs_disk
 		&uri_escaped
-		&a_href &a_href_cz
+		&a_href &a_href_cc
 		&vskip
 		&img &centerimg &rightimg
 		$W
 		&input_hidden_persistents
+		&escapeHTML
 		);
 our @ISA=qw(Tie::Handle Exporter);
 
+my %packages_used_hash;	# $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
+my %packages_used_array;
+
 BEGIN
 {
 	use Carp qw(cluck confess);
@@ -63,8 +67,10 @@ BEGIN
 		for my $target ($class,__PACKAGE__) {
 			for my $caller (keys(%callers)) {
 				next if $caller eq $target;
-				next if $W->{'packages_used%'}{$caller}{$target}++;
-				push @{$W->{'packages_used@'}{$caller}},$target;
+				next if $packages_used_hash{$caller}{$target}++;
+				cluck "Appending to the '_done' package list: caller=$caller,target=$target"
+						if $packages_used_hash{$caller}{"_done"};
+				push @{$packages_used_array{$caller}},$target;
 				}
 			}
 		eval { CORE::require "$file"; } or confess $@;
@@ -93,36 +99,37 @@ BEGIN
 }
 
 use WebConfig;	# see also below: Wuse 'WebConfig';
-require CGI;	# for &escapeHTML
+require CGI;
 require Image::Size;	# for &imgsize
 use File::Basename;	# &basename
 use Carp qw(cluck confess);
 use URI::Escape;
 require HTTP::BrowserDetect;
 require HTTP::Negotiate;
-my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; }
+our $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; }
 # Do not: use ModPerl::Util qw(exit);
 # to prevent in mod_perl2: "exit" is not exported by the ModPerl::Util module
 # I do not know why.
 use POSIX qw(strftime);
 use Tie::Handle;
-use Apache2::Const qw(HTTP_MOVED_TEMPORARILY);
+use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK HTTP_OK);
 use URI;
 use URI::QueryParam;
 use Cwd;
+require HTTP::Date;
+require Storable;
+require Digest::MD5;
+require Data::Compare;
+use Data::Dumper;
+require Encode;
+use Apache2::Filter;
+use Apache2::Connection;
+require MIME::Base64;
+use Apache2::ServerUtil;
+require MIME::Types;
 
 
 #our $W;
-		# $W->{"title"}
-		# $W->{"head"}
-		# $W->{"force_charset"}
-		# $W->{"heading_done"}
-		# $W->{"footer_passed"}
-		# %{$W->{"headers"}}
-		# %{$W->{"headers_lc"}}	# maps lc($headers_key)=>$headers_key
-		# @{$W->{'packages_used@'}{callers...}}
-		# %{$W->{'packages_used%'}{callers...}}
-		# %{$W->{"args"}}
 
 sub init ($%)
 {
@@ -134,31 +141,38 @@ my($class,%args)=@_;
 	# We cannot do it in BEGIN { } block
 	# as it would not be tracked for each of the toplevel users later.
 	Wuse 'WebConfig';
-	Wrequire 'My::Hash::Sub';
-
-	my $packages_used_array_save=$W->{'packages_used@'};
-	my $packages_used_hash_save =$W->{'packages_used%'};
-	$W={};
-	tie %$W,"My::Hash::Sub";
-	%$W=(%WebConfig,%args);	# override %WebConfig settings
-	$W->{'packages_used@'}=$packages_used_array_save;
-	$W->{'packages_used%'}=$packages_used_hash_save;
-	$W->{"__PACKAGE__"}||=caller();
+	Wrequire 'My::Hash';
+
+	# $W={} can get somehow created very easily.
+	cluck "W not empty:\n".Dumper($W) if keys(%$W);
+	$W=My::Hash->new({},"My::Hash::Sub","My::Hash::Push");
+	bless $W,$class;
+	%$W=(
+		"__PACKAGE__"=>scalar(caller()),
+		%WebConfig,
+		%args,	# override %WebConfig settings
+		);
 
 	# {"__PACKAGE__"} is mandatory for mod_perl-2.0;
 	# $Apache2::Registry::curstash is no longer supported.
 	do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";
-
-	do { $W->{$_}=0  if !defined $W->{$_}; } for ("detect_ent");
-	do { $W->{$_}=0  if !defined $W->{$_}; } for ("detect_js");
-	do { $W->{$_}=1  if !defined $W->{$_}; } for ("have_css");	# AFAIK it does not hurt anyone.
-	do { $W->{$_}=1  if !defined $W->{$_}; } for ("footer");
-	do { $W->{$_}=1  if !defined $W->{$_}; } for ("footer_delimit");
-	do { $W->{$_}=1  if !defined $W->{$_}; } for ("footer_ids");
-	do { $W->{$_}=1  if !defined $W->{$_}; } for ("indexme");
-	do { $W->{$_}="" if !defined $W->{$_}; } for ("head");
-	do { $W->{$_}="" if !defined $W->{$_}; } for ("body_attr");
-	do { $W->{$_}="en-US" if !defined $W->{$_}; } for ("language");
+	exit_hook_start();
+
+	# See: &escapeHTML
+	do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset();
+	CGI::charset("utf-8");
+
+	do { $W->{$_}=0  if !defined $W->{$_}; } for "detect_ent";
+	do { $W->{$_}=0  if !defined $W->{$_}; } for "detect_js";
+	do { $W->{$_}=1  if !defined $W->{$_}; } for "have_css";	# AFAIK it does not hurt anyone.
+	do { $W->{$_}=0  if !defined $W->{$_}; } for "css_inherit";
+	do { $W->{$_}=1  if !defined $W->{$_}; } for "footer";
+	do { $W->{$_}=1  if !defined $W->{$_}; } for "footer_delimit";
+	do { $W->{$_}=1  if !defined $W->{$_}; } for "footer_ids";
+	do { $W->{$_}=1  if !defined $W->{$_}; } for "indexme";
+	do { $W->{$_}="" if !defined $W->{$_}; } for "head";
+	do { $W->{$_}="" if !defined $W->{$_}; } for "body_attr";
+	do { $W->{$_}="en-US" if !defined $W->{$_}; } for "language";
 
 	my $footer_any=0;
 	for (qw(footer_ids)) {
@@ -170,6 +184,10 @@ my($class,%args)=@_;
 
 	$W->{"r"}=Apache2::RequestUtil->request();
 
+	$W->{"r"}->push_handlers("PerlCleanupHandler"=>\&cleanup);
+
+	$W->{"web_hostname"}||=$W->{"r"}->hostname();
+
 	tie *STDOUT,$W->{"r"};
 	select *STDOUT;
 	$|=1;
@@ -195,35 +213,117 @@ my($class,%args)=@_;
 	do { $W->{"r"}->args(""); delete $ENV{"QUERY_STRING"}; } if $W->{"r"}->method() eq "POST";
 	# Do not: $W->{"r"}->args()
 	# as it parses only QUERY_STRING (not POST data).
-	$W->{"args"}={ CGI->new($W->{"r"})->Vars() };
+	$W->{"args_orig_array"}=[ CGI->new($W->{"r"})->Vars() ];
+	$W->{"args"}={ @{$W->{"args_orig_array"}} };
 	for my $name (keys(%{$W->{"args"}})) {
 		my @vals=split /\x00/,$W->{"args"}{$name};
 		next if @vals<=1;
 		$W->{"args"}{$name}=[@vals];
 		}
 
-	do { $W->{$_}=$W->{"r"}->headers_in()->{"Accept"}         if !defined $W->{$_}; } for ("accept");
-	do { $W->{$_}=$W->{"r"}->headers_in()->{"User-Agent"}||"" if !defined $W->{$_}; } for ("user_agent");
+	$W->{"headers_in"}=$W->{"r"}->headers_in();
+	Wrequire 'My::Hash::Merge';
+	$W->{"headers_in"}=My::Hash::Merge->new(
+			$W->{"headers_in"},
+			My::Hash::Sub->new({
+				"_remote_ip"=>sub { return $W->{"r"}->connection()->remote_ip(); },
+				}),
+			);
+	Wrequire 'My::Hash::Readonly';
+	$W->{"headers_in"}=My::Hash::Readonly->new($W->{"headers_in"});
+	
+	if ($W->{"r"}->method() eq "GET" || $W->{"r"}->method() eq "HEAD") {
+		for (\$W->{"http_safe"}) {
+			# Do not: # Extend the current ETag system instead if you would need it:
+			#         cluck "Explicitely NOT HTTP-Safe for method \"".$W->{"r"}->method()."\"?!?"
+			#         		if defined($$_) && !$$_;
+			# as sometimes it just does not make sense to cache it.
+			$$_=1 if !defined $$_;
+			}
+		}
+	else {
+		for (\$W->{"http_safe"}) {
+			cluck "Undefined HTTP-Safe-ty for method \"".$W->{"r"}->method()."\"!"
+					if !defined($$_);
+			$$_=0 if !defined $$_;
+			}
+		}
+	if ($W->{"http_safe"}) {
+		Wrequire 'My::Hash::RecordKeys';
+		$W->{"headers_in_RecordKeys"}=My::Hash::RecordKeys->new($W->{"headers_in"});
+		$W->{"headers_in"}=$W->{"headers_in_RecordKeys"};
+		}
 
-	$W->{"browser"}=HTTP::BrowserDetect->new($W->{"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);
+		$W->{"have_style"}=sub {
+			# Lazy-evaluation, we may not need the "User-Agent" header at all.
+			return our $r||=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0);
+			};
 		}
 
 	$W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0);
 	if ($W->{"detect_js"} && !$W->{"have_js"}) {
-		$W->{"head"}.='<script type="text/javascript" src="'.path_web('/have_js.pm').'"></script>'."\n";
+		$W->{"head"}.='<script type="text/javascript" src="'.uri_escaped(path_web('/My/HaveJS.pm')).'"></script>'."\n";
 		}
 
-	do { args_check(%$_) if $_; } for ($W->{"args_check"});
+	do { _args_check(%$_) if $_; } for ($W->{"args_check"});
 
-	$ENV{"HOSTNAME"}||=$W->{"web_hostname"};
+	$W->{"_init_done"}=1;
+	return $W;
+}
+
+sub cleanup($)
+{
+my($apache_request)=@_;
+
+	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;
+}
 
-	return bless $W,$class;
+# 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;
+sub exit_hook
+{
+	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();
 }
 
-# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself.
+# Be aware other parts of code (non-My::Web) will NOT use this function!
+# Do not: Wprint $W->{"heading"},"undef"=>1;
+# as we would need to undef() it to turn it off and it would get defaulted in such case.
+# Do not: exists $W->{"heading"}
+# as we use a lot of 'for $W->{"heading"}' which instantiates it with the value: undef()
 sub Wprint($%)
 {
 my($text,%args)=@_;
@@ -231,35 +331,39 @@ my($text,%args)=@_;
 	cluck "undef Wprint" if !defined $text && !$args{"undef"};
 	delete $args{"undef"};
 	cluck join(" ","Invalid arguments:",keys(%args)) if keys(%args);
-	$W->{"r"}->puts($text) if defined $text;
+	return if !defined $text;
+	# Do not: cluck "utf-8 untested" if Encode::is_utf8($text);
+	# as it is valid here.
+	$W->{"r"}->puts($text);
 }
 
-sub escapeHTML($)
+sub request_check(;$)
 {
-my($text)=@_;
+my($self)=@_;
 
 	# Use &eval to prevent: Global $r object is not available. Set:\n\tPerlOptions +GlobalRequest\nin ...
 	# CGI requires valid "r": check it beforehand here.
-	confess "Calling dynamic URL generator from a static code" if !eval { Apache2::RequestUtil->request(); };
-	return CGI::escapeHTML($text);
+	confess "Calling sensitive dynamic code from a static code" if !eval { Apache2::RequestUtil->request(); };
+	# Do not: confess "Calling sensitive dynamic code without My::Web::init" if !$W->{"__PACKAGE__"};
+	# as it is valid at least while preparing arguments to call: &project::Lib::init
 }
 
-# local *FH;
-# tie *FH,ref($W),$W;
-sub TIEHANDLE($)
+sub escapeHTML($)
 {
-my($class,$W)=@_;
-
-	my $self={};
-	$self->{"W"}=$W or confess "Missing W";
-	return bless $self,$class;
-}
+my($text)=@_;
 
-sub WRITE
-{
-my($self,$scalar,$length,$offset)=@_;
+	# Prevent &CGI::escapeHTML breaking utf-8 strings like: \xC4\x9B eq \x{11B}
+	# Prevent case if we run under mod_perl but still just initializing:
+	request_check() if $ENV{"MOD_PERL"};
+	# Generally we are initialized from &init but we may be used without it without mod_perl
+	# and in such case check the change on all non-first invocations.
+	our $init;
+	if (!$ENV{"MOD_PERL"} && $init++) {
+		do { cluck "charset==$_" if $_ ne "utf-8"; } for CGI::charset();
+		}
+	CGI::charset("utf-8");
 
-	Wprint substr($scalar,0,$length);
+	return CGI::escapeHTML($text);
 }
 
 # /home/user/www/webdir
@@ -286,13 +390,14 @@ sub dir_top_abs_disk()
 
 sub unparsed_uri()
 {
+	request_check();
 	if (!$W->{"unparsed_uri"}) {
 		# Do not: $W->{"r"}
 		# as we may be called before &init from: &My::Project::init
 		my $r=Apache2::RequestUtil->request();
 		cluck "Calling ".'&unparsed_uri'." from a static code, going to fail" if !$r;
 		my $uri_string=$r->unparsed_uri() or cluck "Valid 'r' missing unparsed_uri()?";
-		my $uri=URI->new_abs($uri_string,"http://".($W->{"web_hostname"}||$WebConfig{"web_hostname"})."/");
+		my $uri=URI->new_abs($uri_string,"http://".$W->{"web_hostname"}."/");
 		$W->{"unparsed_uri"}=$uri;
 		}
 	return $W->{"unparsed_uri"};
@@ -315,6 +420,7 @@ my($in)=@_;
 }
 
 # $args{"uri_as_in"}=1 to permit passing URI objects as: $in
+# $args{"abs"}=1;
 sub path_web($%)
 {
 my($in,%args)=@_;
@@ -336,6 +442,13 @@ my($in,%args)=@_;
 	return $uri->rel(unparsed_uri());
 }
 
+sub path_abs_disk_register($)
+{
+my($path_abs_disk)=@_;
+
+	$W->{"path_abs_disk_register"}{$path_abs_disk}=1;
+}
+
 # $args{"uri_as_in"}=1 to permit passing URI objects as: $in
 sub path_abs_disk($%)
 {
@@ -346,12 +459,14 @@ my($in,%args)=@_;
 	cluck if !uri_is_local($uri);
 	my $path=$uri->path();
 	cluck "URI compatibility: ->path() not w/leading slash of URI \"$uri\"; path: $path" if $path!~m{^/};
-	return dir_top_abs_disk().$path;
+	my $r=dir_top_abs_disk().$path;
+	path_abs_disk_register $r if !defined $args{"register"} || $args{"register"};
+	return $r;
 }
 
 sub fatal (;$);
 
-sub args_check (%)
+sub _args_check (%)
 {
 my(%tmpl)=@_;
 
@@ -398,21 +513,38 @@ my($msg)=@_;
 	Wprint "\n".vskip("3ex")."<hr /><h1 class=\"error\">FATAL ERROR: $msg!</h1>\n"
 			."<p>You can report this problem's details to"
 			." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".</p>\n";
-	footer();
+	exit;
 }
 
-sub footer (;$)
+sub footer_packages_used_comments()
 {
-	exit 1 if $W->{"footer_passed"}++;	# deadlock prevention:
-
-	Wprint vskip if $W->{"footer_delimit"};
+	my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}};
+	for my $package (@$packages_used) {
+		my $cvs_id=(eval('$'.$package."::CVS_ID")
+#				|| $package	# debug
+				);
+		Wprint '<!-- '.$package.' - $'.$cvs_id.'$ -->'."\n" if $cvs_id;
+		}
+}
 
-	Wprint $W->{"footing_delimit"},"undef"=>1;
+sub footer()
+{
+	cluck 'Explicit &footer call is deprecated, !_exit_dne' if !$W->{"_exit_done"};
+	exit if $W->{"footer_done"}++;	# deadlock prevention:
+	&{$_}() for reverse @{$W->{"footer_sub_push"}};
+	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"}};
 	Wprint "<hr />\n" if $W->{"footer"};
 
-	my $packages_used=$W->{'packages_used@'}{$W->{"__PACKAGE__"}};
+	# Never update the package list while we examine it!
+	$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
 
+	my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}};
 	if ($W->{"footer_ids"}) {
 		Wprint '<p class="cvs-id">';
 		Wprint join("<br />\n",map({ my $package=$_;
@@ -451,30 +583,22 @@ sub footer (;$)
 		Wprint "</p>\n";
 		}
 
-	for my $package (@$packages_used) {
-		my $cvs_id=(eval('$'.$package."::CVS_ID")
-#				|| $package	# debug
-				);
-		Wprint '<!-- '.$package.' - $'.$cvs_id.'$ -->'."\n" if $cvs_id;
-		}
+	packages_used_comments();
 
-	Wprint $W->{"footing"},"undef"=>1;
+	do { Wprint $_ if $_; } for $W->{"footing"};
 
 	Wprint "</body></html>\n";
-	exit 0;
+	exit;
 }
 
-sub header (%)
+# Existing entries are overwritten.
+sub header(%)
 {
 my(%pairs)=@_;
 
 	while (my($key,$val)=each(%pairs)) {
 		do { cluck "Headers already sent"; next; } if $W->{"heading_done"};
-		for ($W->{"headers_lc"}{lc $key} || ()) {
-			delete $W->{"headers"}{$_};
-			}
-		$W->{"headers_lc"}{lc $key}=$key;
-		$W->{"headers"}{$key}=$val;
+		$W->{"r"}->headers_out()->set($key,$val);
 		}
 }
 
@@ -512,17 +636,20 @@ my($uri)=@_;
 	cluck if !ref $uri;
 	my $urient=escapeHTML($uri);
 	return $uri    if $uri eq $urient;
+	request_check();
 	return $urient if uri_is_local $uri;
 	return $uri    if defined $W->{"have_ent"} && !$W->{"have_ent"};	# non-ent client
 	return $urient if $W->{"have_ent"};	# ent client
 	# Unknown client, &escapeHTML should not be needed here:
-	return escapeHTML(path_web('/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri()))));
+	return escapeHTML(path_web('/My/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri()))));
 }
 
+our $a_href_inhibited;
 sub a_href($;$%)
 {
 my($in,$contents,%args)=@_;
 
+	request_check();
 	do { $$_=1 if !defined $$_; } for (\$args{"size"});
 	if (!defined $contents) {
 		$contents=$in;
@@ -531,6 +658,7 @@ my($in,$contents,%args)=@_;
 		}
 	$contents=~s#<a\b[^>]*>##gi;
 	$contents=~s#</a>##gi;
+	return $contents if $a_href_inhibited;
 
 	my $path_web=path_web $in,%args;
 	my $r="";
@@ -547,8 +675,17 @@ my($in,$contents,%args)=@_;
 	return $r;
 }
 
+sub a_href_inhibit($$;@)
+{
+my($self,$sub,@sub_args)=@_;
+
+	local $a_href_inhibited=1;
+	return &{$sub}(@sub_args);
+}
+
 sub input_hidden_persistents()
 {
+	request_check();
 	return join("",map({
 		my $key=$_;
 		my $val=$W->{"args"}{$key};
@@ -568,6 +705,8 @@ my($self,$url,$status)=@_;
 	$W->{"r"}->status($status);
 	$W->{"r"}->headers_out()->{"Location"}=$url;
 	$W->{"header_only"}=1;
+	$W->{"content_type"}=0;
+	$W->{"charset"}=0;
 	My::Web->heading();
 	exit;
 	die "NOTREACHED";
@@ -580,22 +719,29 @@ sub remote_ip ()
 	# As 'Apache2::ForwardedFor' takes the first of $ENV{"HTTP_X_FORWARDED_FOR"}
 	# while the contents is '127.0.0.1, 213.220.195.171' if client has its own proxy.
 	# We must take the last item ourselves.
-	my $r=$W->{"r"}->headers_in()->{"X-Forwarded-For"} || $W->{"r"}->get_remote_host();
-	$r=~s/^.*,\s*//;
+	# Be VERY sure you always retrieve all the headers unconditionally to hit: My::Hash::RecordKeys
+	my $x_forwarded_for=$W->{"headers_in"}{"X-Forwarded-For"};
+	$x_forwarded_for=~s/^.*,\s*// if $x_forwarded_for;
+	my $remote_ip=$W->{"headers_in"}{"_remote_ip"};
+	my $r;
+	$r||=$x_forwarded_for;
+	$r||=$remote_ip;
 	return $r;
 }
 
-sub is_cz ()
-{
-	return 0 if !$have_Geo_IP;
-	return "CZ" eq Geo::IP->new()->country_code_by_addr(remote_ip());
-}
-
-sub a_href_cz ($$;%)
+# $url={"JP"=>"http://specific",...};
+# $url={""=>"http://default",...};
+sub a_href_cc($$;%)
 {
 my($url,$contents,%args)=@_;
 
-	return a_href $url,$contents,%args if is_cz();
+	# A bit ineffective but we must process all the possibilities to get stable 'headers_in' hits!
+	my %map=map(($_=>a_href($url->{$_},$contents,%args)),keys(%$url));
+	my $cc;
+	$cc||=Geo::IP->new()->country_code_by_addr(remote_ip()) if $have_Geo_IP;
+	$cc||="";
+	my $r=$map{$cc};
+	return $r if $r;
 	return $contents;
 }
 
@@ -646,6 +792,13 @@ sub Negotiate_choose($$)
 {
 my($self,$variants)=@_;
 
+	# Limit these entries to generate proper 'Vary' header.
+	my %hash=(map(($_=>$W->{"headers_in"}{$_}),qw(
+			Accept
+			Accept-Charset
+			Accept-Encoding
+			Accept-Language
+			)));
 	my $best=HTTP::Negotiate::choose($variants,
 			# Do not: $W->{"r"}
 			# to prevent: Can't locate object method "scan" via package "Apache2::RequestRec" at HTTP/Negotiate.pm line 84.
@@ -653,7 +806,7 @@ my($self,$variants)=@_;
 			# to prevent: Can't locate object method "scan" via package "APR::Table" at HTTP/Negotiate.pm line 84.
 			# Do not: HTTP::Headers->new($W->{"r"}->headers_in());
 			# to prevent empty result or even: Odd number of elements in anonymous hash
-			HTTP::Headers->new(%{$W->{"r"}->headers_in()}));
+			HTTP::Headers->new(%hash));
 	$best||=$variants->[0][0];	# $variants->[0]{"id"}; &HTTP::Negotiate::choose failed?
 	return $best;
 }
@@ -672,7 +825,7 @@ my($in,%args)=@_;
 
 	cluck if !uri_is_local $in;
 	my $uri=in_to_uri_abs $in;
-	my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1;
+	my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1,"register"=>0;
 
 	# Known image extension?
 	return path_web($uri,%args,"uri_as_in"=>1),$path_abs_disk if $uri->path()=~m#$img_variants_re#o;
@@ -680,6 +833,7 @@ my($in,%args)=@_;
 	my @nego_variants;
 	for my $var (@img_variants) {
 		my $path_abs_disk_variant=$path_abs_disk.".".$var->{"id"};
+		path_abs_disk_register($path_abs_disk_variant);
 		__PACKAGE__->make_file($path_abs_disk_variant);
 		push @nego_variants,negotiate_variant(
 				%$var,
@@ -697,6 +851,7 @@ sub img ($$%)
 {
 my($in,$alt,%args)=@_;
 
+	request_check();
 	my($path_web,$path_abs_disk)=_img_src($in,%args);
 	my($width,$height)=Image::Size::imgsize($path_abs_disk);
 	$alt=~s/<[^>]*>//g;
@@ -753,44 +908,214 @@ my($class,$filename)=@_;
 	return $F;
 }
 
-sub no_cache($)
+sub _no_cache($)
 {
 my($self)=@_;
 
-	header("Expires"=>"Mon, 26 Jul 1997 05:00:00 GMT");	# date in the past
-	header("Last-Modified"=>strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime()));	# always modified
-	header("Cache-Control"=>"no-cache, must-revalidate");	# HTTP/1.1
+	header("Expires"=>HTTP::Date::time2str(1000000000));	# date in the past
+	header("Last-Modified"=>HTTP::Date::time2str());	# always modified
+	header("Cache-Control"=>join(", ",
+			"no-cache",
+			"no-store",
+			"must-revalidate",
+			"max-age=0",
+			"pre-check=0",	# MSIE
+			"post-check=0",	# MSIE
+			));	# HTTP/1.1
 	header("Pragma"=>"no-cache");	# HTTP/1.0
+	header("Vary"=>"*");	# content may ba based on unpredictable sources
+}
+
+sub headers_in_filtered(@)
+{
+my(@keys)=@_;
+
+	return map(($_=>$W->{"headers_in"}{$_}),@keys);
+}
+
+our %uri_args_frozen_to_headers_in_keys;
+our %uri_args_headers_in_frozen_to_headers_out;
+
+sub uri_args_headers_in_frozen_get($)
+{
+my($headers_in_keys_arrayref)=@_;
+
+	my %uri_args_headers_in_hash=(
+		"uri_args_frozen"=>$W->{"uri_args_frozen"},
+		"headers_in"=>{ headers_in_filtered(@$headers_in_keys_arrayref) },
+		);
+	return do { local $Storable::canonical=1; Storable::freeze(\%uri_args_headers_in_hash); };
+}
+
+sub cache_output_filter($)
+{
+my($f)=@_;
+
+	while ($f->read(my $text,0x400)) {
+		cluck "utf-8 untested" if Encode::is_utf8($text);	# Possible here at all?
+		$f->print($text);
+		$W->{"digest-md5"}->add($text);
+		}
+	return OK;
+}
+
+sub cache_start()
+{
+	if (!$W->{"http_safe"}) {
+		__PACKAGE__->_no_cache();
+		return;
+		}
+
+	{
+		# &Wrequire it here even if it will not be later used; to be stable!
+		Wrequire 'My::Hash::RestrictTo';
+		my %uri_args_hash=(
+			"uri"=>"http://".$W->{"web_hostname"}."/".$W->{"r"}->uri(),
+			"args"=>$W->{"args_orig_array"},
+			);
+		$W->{"uri_args_frozen"}=do { local $Storable::canonical=1; Storable::freeze(\%uri_args_hash); };
+		last if !(my $headers_in_keys_arrayref=$uri_args_frozen_to_headers_in_keys{$W->{"uri_args_frozen"}});
+
+		# Protection to be sure we are stable:
+		$W->{"headers_in"}=My::Hash::RestrictTo->new($W->{"headers_in"},@$headers_in_keys_arrayref);
+
+		$W->{"uri_args_headers_in_frozen"}=uri_args_headers_in_frozen_get($headers_in_keys_arrayref);
+		last if !(my $headers_out_hashref=$uri_args_headers_in_frozen_to_headers_out{$W->{"uri_args_headers_in_frozen"}});
+		header(%$headers_out_hashref);
+		my $status;
+		{
+			# &meets_conditions will always deny the attempt if !2xx status().
+			# At least ap_read_request() sets: r->status=HTTP_REQUEST_TIME_OUT;	/* Until we get a request */
+			my $status_old=$W->{"r"}->status();
+			$W->{"r"}->status(HTTP_OK);
+			# Update httpd's 'r->mtime' as the header "Last-Modified" is just not enough for ap_meets_conditions():
+			# &update_mtime() argument is really in _secs_, not in _msecs_ as the docs claim.
+			# Be aware '*1000000' would overflow Perl integer anyway.
+			# &set_last_modified would also override the "Last-Modified" headers_out!
+			# &mtime may exist but somehow does not work.
+			$W->{"r"}->update_mtime(HTTP::Date::str2time($headers_out_hashref->{"Last-Modified"}));
+			$status=$W->{"r"}->meets_conditions();
+			$W->{"r"}->status($status_old);
+			}
+		last if OK==$status;
+		$W->{"r"}->status($status);
+		$W->{"header_only"}=1;	# Inhibit &footer output.
+		exit;
+		die "NOTREACHED";
+		}
+
+	$W->{"digest-md5"}=Digest::MD5->new();
+	$W->{"cache_active"}=1;
+	$W->{"r"}->add_output_filter(\&cache_output_filter);
+}
+
+sub cache_finish_last_modified()
+{
+	cluck "Not yet done now? W __PACKAGE__: ".$W->{"__PACKAGE__"}
+			if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"};
+	for my $package_orig (@{$packages_used_array{$W->{"__PACKAGE__"}}}) {
+		local $_=$package_orig.".pm";
+		s{::}{/}g;
+		path_abs_disk "/$_","register"=>1;
+		}
+	my $mtime_newest;
+	for my $path_abs_disk (keys(%{$W->{"path_abs_disk_register"}})) {
+		my $mtime=(stat $path_abs_disk)[9];
+		do { cluck "No mtime for: $path_abs_disk"; next; } if !$mtime;
+		$mtime_newest=$mtime if !$mtime_newest || $mtime_newest<$mtime;
+		}
+	cluck "No mtime_newest found for the current W __PACKAGE__: ".$W->{"__PACKAGE__"}
+			if !$mtime_newest;
+	return HTTP::Date::time2str($mtime_newest);
+}
+
+
+sub cache_finish()
+{
+	# Do not: return if !$W->{"uri_args_frozen"};
+	# as we may have just gave 304 and 'exit;' without starting the caching.
+	return if !$W->{"cache_active"};
+
+	# Fill-in/check: %uri_args_frozen_to_headers_in_keys
+	my $headers_in_keys_stored_arrayref_ref=\$uri_args_frozen_to_headers_in_keys{$W->{"uri_args_frozen"}};
+	my @headers_in_keys=tied(%{$W->{"headers_in_RecordKeys"}})->accessed();
+	if (!$$headers_in_keys_stored_arrayref_ref
+			|| !Data::Compare::Compare(\@headers_in_keys,$$headers_in_keys_stored_arrayref_ref)) {
+		cluck "Non-matching generated 'headers_in_keys' per 'uri_args_frozen' key:\n"
+						.Dumper(\@headers_in_keys,$$headers_in_keys_stored_arrayref_ref)
+				if $$headers_in_keys_stored_arrayref_ref;
+		# Build or possibly prevent such further warn dupes:
+		$$headers_in_keys_stored_arrayref_ref=\@headers_in_keys;
+		# Build or regenerate as obsoleted now:
+		$W->{"uri_args_headers_in_frozen"}=uri_args_headers_in_frozen_get(\@headers_in_keys);
+		}
+
+	# Prepare 'headers_out' for the future reusal:
+	my %headers_out;
+	# Do not: $W->{"digest-md5"}->b64digest();
+	# as it will not provide the trailing filling '='s.
+	# RFC 1864 is not clear if they should be there but its sample provides them.
+	# Do not try to provide canonical "\r\n" form of newlines as is said by RFC 1864.
+	# RFC 2068 (HTTP/1.1) section 14.16 says the newlines should NOT be converted for HTTP.
+	# ',""' to avoid breaking the headers by its default "\n".
+	$headers_out{"Content-MD5"}=MIME::Base64::encode_base64($W->{"digest-md5"}->digest(),"");
+	# In fact we could also use MD5 for ETag as if we know ETag we also know MD5.
+	# But this way we do not need to calculate MD5 and we still can provide such ETag. So.
+	# $W->{"r"}->set_etag() ?
+	$headers_out{"ETag"}='"'.Digest::MD5::md5_base64($W->{"uri_args_headers_in_frozen"}).'"';
+	# $W->{"r"}->set_content_length() ?
+	$headers_out{"Content-Length"}=$W->{"r"}->bytes_sent();
+	my %Vary=map(($_=>1),(@headers_in_keys));
+	for (keys(%Vary)) {
+		next if !/^_/;
+		$Vary{"*"}=1;
+		delete $Vary{$_};
+		}
+	%Vary=("*"=>1) if $Vary{"*"};
+	$headers_out{"Vary"}=join(", ",sort keys(%Vary)) if keys(%Vary);
+	# $W->{"r"}->set_last_modified() ?
+	$headers_out{"Last-Modified"}=cache_finish_last_modified();
+
+	# Fill-in/check: %uri_args_headers_in_frozen_to_headers_out
+	my $headers_out_stored_hashref_ref=\$uri_args_headers_in_frozen_to_headers_out{$W->{"uri_args_headers_in_frozen"}};
+	if (!$$headers_out_stored_hashref_ref
+			|| !Data::Compare::Compare(\%headers_out,$$headers_out_stored_hashref_ref)) {
+		cluck "Non-matching generated 'headers_out' per 'uri_args_headers_in_frozen' key:\n"
+						.Dumper(\%headers_out,$$headers_out_stored_hashref_ref)
+				if $$headers_out_stored_hashref_ref;
+		# Build or possibly prevent such further warn dupes:
+		$$headers_out_stored_hashref_ref=\%headers_out;
+		}
+
+###print STDERR Dumper(\%uri_args_frozen_to_headers_in_keys,\%uri_args_headers_in_frozen_to_headers_out);
 }
 
 sub heading()
 {
 my($class)=@_;
 
-	# $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!)
-	my $client_charset=$W->{"force_charset"} || "us-ascii";
-	header("Content-Style-Type"=>"text/css");
-	header("Content-Script-Type"=>"text/javascript");
-	do { header("Content-Language"=>$_) if $_; } for $W->{"language"};
-	$class->no_cache() if $W->{"no_cache"};
-
-	while (my($key,$val)=each(%{$W->{"headers"}})) {
-		$W->{"r"}->headers_out()->{$key}=$val;
+	if (!$W->{"header_only"}) {
+		header("Content-Style-Type"=>"text/css");
+		header("Content-Script-Type"=>"text/javascript");
+		# $W->{"r"}->content_languages() ?
+		do { header("Content-Language"=>$_) if $_; } for $W->{"language"};
 		}
-	exit if $W->{"r"}->header_only();
-	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"}++;
+	# TODO: Support also: private
+	header("Cache-Control"=>"public");	# HTTP/1.1
+
+	# 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;
 	# http://validator.w3.org/ does not send ANY "Accept" headers!
-	$mime||="application/xhtml+xml" if !$W->{"accept"} && $W->{"user_agent"}=~m{^W3C_Validator/}i;
-	$mime||=$class->Negotiate_choose([
+	$W->{"content_type"}="application/xhtml+xml" if !defined $W->{"content_type"}
+			&& !$W->{"headers_in"}{"Accept"}
+			&& ($W->{"headers_in"}{"User-Agent"}||"")=~m{^W3C_Validator/}i;
+	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
@@ -801,33 +1126,64 @@ 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 ?
 			# text/xml ?
 			]);
-	$W->{"r"}->content_type("$mime; charset=$client_charset");
-	Wprint '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n" if $mime=~m{^application/\w+[+]xml$};
-	return if $W->{"xml_header_only"};
+	# 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;
+	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="'.$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"}++;
+
 	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"} || ())));
+	# Do not: cluck if $title=~/[<>]/;
+	# as it is not solved just by: &a_href_inhibit
+	# as sometimes titles use also: <i>...</i>
 	$title=~s#<[^>]*>##g;
 	Wprint "<head>";
 	Wprint "<title>$title</title>\n";
 	if ($W->{"have_css"}) {
 		# Everything can get overriden later.
-		Wprint <<"HERE";
-<link rel="stylesheet" type="text/css" href="@{[ uri_escaped(path_web "/My/Web.css") ]}" />
+		for my $css ("/My/Web.css",@{$W->{"css_push"}}) {
+			Wprint <<"HERE";
+<link rel="stylesheet" type="text/css" href="@{[ uri_escaped(path_web $css) ]}" />
 HERE
+			}
+		if ($W->{"css_inherit"}) {
+			Wprint <<"HERE";
+<script type="text/javascript" src="@{[ uri_escaped(path_web('/My/css_inherit.js')) ]}" />
+HERE
+			}
 		}
 	Wprint '<meta name="robots" content="'.($W->{"indexme"} ? "" : "no" ).'index,follow" />'."\n";
 	Wprint $W->{"head"};
@@ -841,7 +1197,7 @@ HERE
 	Wprint $W->{"body_attr"};
 	Wprint ">\n";
 
-	Wprint $W->{"heading"},"undef"=>1;
+	do { Wprint $_ if $_; } for $W->{"heading"};
 }
 
 BEGIN {