# $Id$
# Common functions for HTML/XHTML output generation
# Copyright (C) 2003 Jan Kratochvil <project-www.jankratochvil.net@jankratochvil.net>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; exactly version 2 of June 1991 is required
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA


package My::Web;
require 5.6.0;	# at least 'use warnings;' but we need some 5.6.0+ modules anyway
our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
our $CVS_ID=q$Id$;
use strict;
use warnings;

use Exporter;
sub Wrequire ($);
sub Wuse ($@);
our $W;
our @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img &centerimg &rightimg $W &top_dir &top_dir_disk &Wprint &input_hidden_persistents);
our @ISA=qw(Exporter Tie::Handle);

BEGIN
{
	$W->{"__My::Web_init"}=1;

	sub Wrequire ($)
	{
	my($file)=@_;

#		print STDERR "Wrequire $file\n";
		$file=~s#/#::#g;
		$file=~s/[.]pm$//;
		my $class=$file;
		$file=~s#::#/#g;
		$file.=".pm";
		my $who=$W->{"__PACKAGE__"};
		$who||="__My::Web" if $W->{"__My::Web_init"};
		if ($who) {
			my $aref=($W->{"packages_used"}{$who}||=[]);
			push @$aref,$class
					if !{ map(($_=>1),@$aref) }->{$class};	# Prevent duplicated entries.
			}
		CORE::require $file;
		1;	# Otherwise 'require' would already file above.
	}

	sub Wuse ($@)
	{
	my($file,@list)=@_;

#		print STDERR "Wuse $file\n";
		Wrequire $file;
		local $Exporter::ExportLevel=$Exporter::ExportLevel+1;
		$file->import(@list);
		1;
	}
}

BEGIN { Wuse 'WebConfig'; }	# for %WebConfig
require CGI;	# for &escapeHTML
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; }; }
use ModPerl::Util qw(exit);
use POSIX qw(strftime);
use Tie::Handle;
use Apache::Const qw(HTTP_MOVED_TEMPORARILY);
use URI;
use URI::QueryParam;


#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"}{$W->{"__PACKAGE__"}}}
		# @{$W->{"packages_used"}{"__My::Web"}}
		# %{$W->{"args"}}

sub init ($%)
{
my($class,%args)=@_;

	print STDERR "$class->init ".Apache->request()->unparsed_uri()."\n";

	my $packages_used_save=$W->{"packages_used"};
	$W={ %WebConfig,%args };	# override %WebConfig settings
	$W->{"packages_used"}=$packages_used_save;

	# {"__PACKAGE__"} is mandatory for mod_perl-2.0;
	# $Apache::Registry::curstash is no longer supported.
	do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";

	$W->{"top_dir"}||=eval '$'.$W->{"__PACKAGE__"}.'::top_dir';

	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_mailme");
	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_mailme footer_ids)) {
		$W->{$_}=0 if !$W->{"footer"};
		$footer_any=1 if $W->{$_};
		}
	$W->{"footer"}=0 if !$footer_any;
	$W->{"footer_delimit"}=0 if !$W->{"footer"};

	$W->{"r"}=Apache->request();

	$W->{"QUERY_STRING"}=$W->{"r"}->args() || "";
	if ($W->{"detect_ent"}) {
			 if ($W->{"QUERY_STRING"}=~/[&]amp;have_ent/)
			{ $W->{"have_ent"}=0; }
		elsif ($W->{"QUERY_STRING"}=~    /[&]have_ent/)
			{ $W->{"have_ent"}=1; }
		else
			{ delete $W->{"have_ent"}; }
		if (!defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") {
			$W->{"head"}.='<meta http-equiv="Refresh" content="0; URL='
					.CGI::escapeHTML("http://".&{$W->{"web_hostname_sub"}}()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0]
							."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect')
					.'" />'."\n";
			}
		}
	$W->{"QUERY_STRING"}=~s/([&])amp;/$1/g;
	$W->{"r"}->args($W->{"QUERY_STRING"});
	# Workaround: &CGI::Vars behaves weird if strings passed both as POST data and in: $QUERY_STRING
	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() };
	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->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"});

	if (!defined $W->{"have_style"}) {
		$W->{"have_style"}=(!$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="'.top_dir('/have_js.js.pl').'"></script>'."\n";
		}

	do { args_check(%$_) if $_; } for ($W->{"args_check"});

	$ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}();

	return bless $W,$class;
}

sub Wprint($)
{
my($text)=@_;

	$W->{"r"}->puts($text);
}

# local *FH;
# tie *FH,ref($W),$W;
sub TIEHANDLE($)
{
my($class,$W)=@_;

	my $self={};
	$self->{"W"}=$W or confess "Missing W";
	return bless $self,$class;
}

sub WRITE
{
my($self,$scalar,$length,$offset)=@_;

	Wprint substr($scalar,0,$length);
}

sub top_dir_disk ()
{
	do { return $_ if $_; } for ($W->{"top_dir"});
	return $INC[0];	# fallback
}

# $args{"abs"}
sub top_dir (;$%)
{
my($in,%args)=@_;

	if (my $uri=$W->{"r"}->unparsed_uri()) {
		if ($W->{"args"}{"Wabs"} || $args{"abs"}) {
			# FIXME: $in may not be defined here!
			# to prevent: Use of uninitialized value in ...
			if ($in=~m#^/#) {
				$in=~s#^/*##;
				}
			else {
				$in=$uri."/".$in;
				$in=~tr#/#/#s;
				1 while $in=~s#/(?:[^/]+)/\Q..\E/#/#g
				}
			return "http://".&{$W->{"web_hostname_sub"}}()."/".(defined $in ? $in : "");
			}
		$uri.="Index" if $uri=~m#/$#;
		if (defined $in) {
			my($inpath,$inquery)=split /[?]/,$in,2;
			$inpath=~tr///cs;
			$uri=~tr///cs;
			for (;;) {
				my($in1 ,$in2 )=($in =~m#^(/[^/]+)(/.*)$#);
				my($uri1,$uri2)=($uri=~m#^(/[^/]+)(/.*)$#);
				last if !defined $in1 || !defined $uri1 || $in1 ne $uri1;
				$in=$in2;
				$uri=$uri2;
				}
			}
		$uri=~s#^/*##;
		$uri=~s#[^/]+#..#g;
		$uri=File::Basename::dirname($uri);
		my $r=$uri.(defined $in ? $in : "");
#		1 while $r=~s#^[.]/##;
#		$r="./$r" if $r=~m#^(?:?.*)$#;	# empty pathname?
		return $r;
		}
	return top_dir_disk().$in;
}

sub fatal (;$);

sub args_check (%)
{
my(%tmpl)=@_;

	while (my($name,$regex)=each(%tmpl)) {
		my $name_html="Parameter <span class=\"quote\">".CGI::escapeHTML($name)."</span>";
		$W->{"args"}{$name}="" if !defined $W->{"args"}{$name};
		$W->{"args"}{$name}=[ $W->{"args"}{$name} ] if !ref $W->{"args"}{$name} && ref $regex;
		fatal "$name_html passed as multivar although singlevar expected"
				if ref $W->{"args"}{$name} && !ref $regex;
		$regex=$regex->[0] if ref $regex;
		for my $val (!ref $W->{"args"}{$name} ? $W->{"args"}{$name} : @{$W->{"args"}{$name}}) {
			$val="" if !defined $val;
			fatal "$name_html <span class=\"quote\">".CGI::escapeHTML($val)."</span>"
							." does not match the required regex <span class=\"quote\">".CGI::escapeHTML($regex)."</span> "
					if $regex ne "" && $val!~/$regex/;
			}
		}
}

sub vskip (;$)
{
my($height)=@_;

	return '<p'.(!defined $height ? "" : ' style="height: '.$height.';"').'>&nbsp;</p>'."\n";
}

sub fatal (;$)
{
my($msg)=@_;

	$msg="UNKNOWN" if !$msg;
	cluck "FATAL: $msg";

	$W->{"indexme"}=0;	# For the case no heading was sent yet.
	$W->{"heading_done"}=0;	# for the case of already sent {"header_only"}==1
	$W->{"header_only"}=0;	# assurance for &heading
	My::Web->heading();
	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();
}

sub footer (;$)
{
	exit 1 if $W->{"footer_passed"}++;	# deadlock prevention:

	Wprint vskip if $W->{"footer_delimit"};

	do { &{$_}() if $_; } for ($W->{"footing_delimit"});

	Wprint "<hr />\n" if $W->{"footer"};

	if ($W->{"footer_mailme"}) {
		Wprint '<form action="'.top_dir('/SendMsg.pl').'" method="post" onsubmit="'
				."this.elements['msgscript'].value=this.elements['msghtml'].value;"
				."this.elements['msghtml'].value='';"
				."this.submit();"
				.'">'."\n";
			Wprint input_hidden_persistents()."\n";
			Wprint '<p align="right">'."\n";
				Wprint '<input name="msgscript" type="hidden" />'."\n";
				Wprint '<input name="msghtml" type="text" size="32" alt="Message" />'."\n";
				Wprint '<input name="submit" type="submit" value="Quick Note" />'."\n";
			Wprint '</p>'."\n";
		Wprint '</form>'."\n";
		}

	my @packages_used=(
			$W->{"__PACKAGE__"},
			__PACKAGE__,
			@{$W->{"packages_used"}{"__My::Web"}},
			map((!$_ ? () : @$_),$W->{"packages_used"}{$W->{"__PACKAGE__"}}),
			);
	my %packages_used;
	@packages_used=grep((!$packages_used{$_}++),@packages_used);
	if ($W->{"footer_ids"}) {
		Wprint '<p class="cvs-id">';
		Wprint join("<br />\n",map({ my $package=$_;
			my $cvs_id=(eval('$'.$package."::CVS_ID")
#					|| $package	# debug
					);
			if (!$cvs_id) {
				();
				}
			else {
				$cvs_id='$'.$cvs_id.'$';	# Eaten by 'q' operator.
				my @cvs_id_split=split / +/,$cvs_id;
				if (@cvs_id_split==8) {
					my $file=$package;
					$file=~s#::#/#g;
					my $ext;
					my @tried;
					for (qw(.html.pl .pl .pm),"") {
						$ext=$_;
						my $pathname=top_dir_disk()."/$file$ext";
						push @tried,$pathname;
						last if -r $pathname;
						cluck "Class file $file not found; tried: ".join(" ",@tried) if !$ext;
						}
					$file.=$ext;
					$cvs_id_split[2]=""
							.a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $W->{"viewcvs"}))[0]."$file?rev=".$cvs_id_split[2],
									$cvs_id_split[2]);
					$cvs_id_split[1]=a_href($W->{"viewcvs"}.$file,
							($package!~/^Apache::/ ? $package : $cvs_id_split[1]));
					$cvs_id_split[5]=&{$W->{"cvs_id_author"}}($cvs_id_split[5]);
					}
				join " ",@cvs_id_split;
				}
			} @packages_used));
		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;
		}

	do { &{$_}() if $_; } for ($W->{"footing"});

	Wprint "</body></html>\n";
	exit(0);
}

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;
		}
}

sub size_display ($)
{
my($size)=@_;

	   if ($size<4096)
		{}
	elsif ($size<1024*1024)
		{ $size=sprintf "%.1fK",$size/1024; }
	else
		{ $size=sprintf "%.1fM",$size/1024/1024; }
	$size.="B";
	return $size;
}

sub url_is_local ($)
{
my($url)=@_;

	return $url!~m#^[a-z]+://#;
}

sub url_out($%)
{
my($url,%args)=@_;

	return $url if !url_is_local $url;
	$url=top_dir($url,%args) if $url=~m#^/# || $args{"abs"};

	my $uri=URI->new($url);
	# Prefer the $uri values over "args_persistent" values.
	$uri->query_form_hash({
			map({
				my $key=$_;
				my $val=$W->{"args"}{$key};
				(!defined $val ? () : ($key=>$val));
				} keys(%{$W->{"args_persistent"}})),
			%{$uri->query_form_hash()},
			});
	$url="".$uri;

	return $url;
}

sub a_href ($;$%)
{
my($url,$contents,%args)=@_;

	do { $$_=1 if !defined $$_; } for (\$args{"size"});
	if (!defined $contents) {
		$contents=$url;
		$contents=File::Basename::basename($contents) if $args{"basename"};
		$contents=CGI::escapeHTML($contents);
		}
	$contents=~s#<a\b[^>]*>##gi;
	$contents=~s#</a>##gi;

	$url=url_out($url,%args);

	my $r='<a href="';
	my $urlent=CGI::escapeHTML($url);
	   if ($url eq $urlent)
		{ $r.=$url; }
	elsif (url_is_local $url)
		{ $r.=$urlent; }
	elsif (defined $W->{"have_ent"} && !$W->{"have_ent"})	# non-ent client
		{ $r.=$url; }
	elsif ($W->{"have_ent"})	# ent client
		{ $r.=$urlent; }
	else	# unknown client, &CGI::escapeHTML should not be needed here
		{ $r.=CGI::escapeHTML(top_dir('/Redirect.pl?location='.uri_escape($url))); }
	$r.='"';
	do { $r.=" $_" if $_; } for ($args{"attr"});
	$r.='>'.$contents.'</a>';
	if ($args{"size"} && url_is_local($url) && ($args{"size"}>=2 || $url=~/[.](?:gz|Z|rpm|zip|deb|lha)/)) {	# Downloadable?
		$url=top_dir_disk().$url if $url=~m#^/#;
		if (!-r $url)
			{ cluck "File not readable: $url"; }
		else {
			$r.='&nbsp;('.size_display((stat($url))[7]).')';
			}
		}
	return $r;
}

sub input_hidden_persistents()
{
	return join("",map({
		my $key=$_;
		my $val=$W->{"args"}{$key};
		(!defined $val ? () : '<input type="hidden"'
				.' name="'.CGI::escapeHTML($key).'"'
				.' value="'.CGI::escapeHTML($val).'"'
				.' />'."\n");
		} (keys(%{$W->{"args_persistent"}}))));
}

sub http_moved($$;$)
{
my($self,$url,$status)=@_;

	$url=url_out($url,"abs"=>1);
	$status||=Apache::HTTP_MOVED_TEMPORARILY;
	$W->{"r"}->status($status);
	$W->{"r"}->header_out("Location"=>$url);
	$W->{"header_only"}=1;
	My::Web->heading();
	exit;
	die "NOTREACHED";
}

sub remote_ip ()
{
	# Do not: PerlModule                 Apache::ForwardedFor
	#         PerlPostReadRequestHandler Apache::ForwardedFor
	# As 'Apache::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*//;
	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 ($$;%)
{
my($url,$contents,%args)=@_;

	return a_href $url,$contents,%args if is_cz();
	return $contents;
}

sub make ($)
{
my($cmd)=@_;

	system {'flock'} 'flock','-x',top_dir_disk(),$cmd.' >&2';
}

sub img_size ($$)
{
my($width,$height)=@_;

	return ($W->{"have_style"} ? "style=\"border:0;width:${width}px;height:${height}px\"" : "border=\"0\"")
			." width=\"$width\" height=\"$height\"";
}

sub negotiate_variant (%)
{
my(%args)=@_;

	my @fields=("id","qs","content-type","encoding","charset","lang","size");
	return [ map(($args{$_}),@fields) ];
}

my @img_variants=(
		{ "id"=>"png","qs"=>1.0,"content-type"=>"image/png" },
		{ "id"=>"gif","qs"=>0.9,"content-type"=>"image/gif" },
		);
my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$';

sub img_src ($)
{
my($file_base)=@_;

	if (!url_is_local($file_base)) {
		return $file_base if !wantarray();
		return ($file_base,$file_base);
		}
	# Known image extension?
	if ($file_base=~m#$img_variants_re#o) {
		return $file_base if !wantarray();
		return ($file_base,$file_base) if $file_base!~m#^/#;
		return (top_dir($file_base),top_dir_disk().$file_base);
		}

	my $file_base_disk;
	my $file_base_uri;
	if ($file_base!~m#^/#) {
		$file_base_disk=$file_base_uri=$file_base;
		}
	else {
		$file_base_disk=top_dir_disk().$file_base;
		$file_base_uri=top_dir($file_base);
		}

	my @nego_variants;
	for my $var (@img_variants) {
		my $file=$file_base_disk.".".$var->{"id"};
		# TODO: Somehow quickly check dependencies?
		make('make -s --no-print-directory'
						.' -C '."'".File::Basename::dirname($file)."' '".File::Basename::basename($file)."'")
				if !-f $file;
		push @nego_variants,negotiate_variant(
				%$var,
				"size"=>(stat $file)[7],
				);
		}
	# Do not: ,$W->{"r"});
	# but should we provide somehow either 'HTTP::Headers' or 'HTTP::Request' ?
	my $ext=HTTP::Negotiate::choose(\@nego_variants);
	$ext||=$img_variants[0]->{"id"};	# &HTTP::Negotiate::choose failed?

	return $file_base_uri.".".$ext if !wantarray();
	return ($file_base_uri.".".$ext,$file_base_disk.".".$ext);
}

sub img ($$;%)
{
my($file_base,$alt,%attr)=@_;

	my($file_uri,$file_disk)=img_src $file_base;
	my($width,$height)=Image::Size::imgsize($file_disk);
	$alt=~s/<[^>]*>//g;
	$alt=CGI::escapeHTML($alt);
	my $content="<img src=\"$file_uri\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
			.(!$attr{"attr"} ? "" : " ".$attr{"attr"})." />";
	return a_href img_src($attr{"a_href_img"}),$content if $attr{"a_href_img"};
	return a_href $attr{"a_href"},$content if $attr{"a_href"};
	return $content;
}

sub centerimg
{
	my $r.="";
	$r.='<table border="0" width="100%"><tr>'."\n";
	@_=( [@_] ) if !ref $_[0];
	for (@_) {
		$r.="\t".'<td align="center">'.&{\&img}(@$_).'</td>'."\n";
		}
	$r.='</tr></table>'."\n";
	return $r;
}

sub rightimg
{
my($text,@args_img)=@_;

	# Workaround bug of 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)':
	return <<"HERE";
<table border="0" width="100%">
	<col width="@{[ (!$W->{"browser"}->ie() ? "1*" : "90%" ) ]}" />
	<col width="@{[ (!$W->{"browser"}->ie() ? "0*" : "10%" ) ]}" />
	<tr>
		<td align="left">
			@{[ $text ]}
		</td>
		<td align="right">
			@{[ &{\&img}(@args_img) ]}
		</td>
	</tr>
</table>
HERE
}

sub readfile ($$)
{
my($class,$filename)=@_;

	local *F;
	open F,$filename or die "Cannot open \"$filename\": $!";
	local $/=undef();
	my $data=<F>;
	close F;
	return $data;
}

sub arr_keys (@)
{
my(@arr)=@_;

	my @r=();
	while (@arr) {
		push @r,shift @arr;	# key
		shift @arr;	# val
		}
	return @r;
}

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("Pragma"=>"no-cache");	# HTTP/1.0
}

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"}->header_out($key,$val);
		}
	if (!$W->{"header_only"}) {
		$W->{"r"}->send_http_header("text/html; charset=$client_charset");	# "Content-type"; do not use header()
		}

	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"}++;

	if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn
		Wprint '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n";
		}
	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"}||"en-US").'">'."\n";
	my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ())));
	$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="@{[ url_out("/My/Web.css") ]}" />
HERE
		}
	Wprint '<meta name="robots" content="'.($W->{"indexme"} ? "" : "no" ).'index,follow" />'."\n";
	Wprint $W->{"head"};
	for my $type (qw(prev next index contents start up)) {
		do { Wprint '<link rel="'.$type.'" href="'.$_.'" />'."\n" if $_; } for ($W->{"rel_$type"});
		}
	Wprint "</head><body";
#	Wprint ' bgcolor="black" text="white" link="aqua" vlink="teal"'
#			if $W->{"browser"}->netscape() && (!$W->{"browser"}->major() || $W->{"browser"}->major()<=4);
	Wprint $W->{"body_attr"};
	Wprint ">\n";

	do { &{$_}() if $_; } for ($W->{"heading"});
}

BEGIN {
	delete $W->{"__My::Web_init"};
	}

1;