# $Id$
# Common functions for HTML/XHTML output generation
# Copyright (C) 2003-2005 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
		&path_web &path_abs_disk
		&uri_escaped
		&a_href &a_href_cz
		&vskip
		&img &centerimg &rightimg
		$W
		&input_hidden_persistents
		);
our @ISA=qw(Tie::Handle Exporter);

BEGIN
{
	use Carp qw(cluck confess);
	$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 %callers;
		for (my $depth=0;defined caller($depth);$depth++) {
			$callers{caller($depth)}=1;
			}
		my $selfpkg=__PACKAGE__;
		$callers{$selfpkg}=1;
		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;
				}
			}
		eval { CORE::require "$file"; } or confess $@;
		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;
	}

	sub import
	{
	my($class,@rest)=@_;

		local $Exporter::ExportLevel=$Exporter::ExportLevel+1;
		Wrequire("$class");
		return $class->SUPER::import(@rest);
	}
}

use WebConfig;	# see also below: Wuse '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; }; }
# 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 URI;
use URI::QueryParam;
use Cwd;


#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 ($%)
{
my($class,%args)=@_;

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

	# We need to track package dependencies, so we need to call it from &init.
	# 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();

	# {"__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");

	my $footer_any=0;
	for (qw(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"}=Apache2::RequestUtil->request();

	tie *STDOUT,$W->{"r"};
	select *STDOUT;
	$|=1;

	$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='
					.escapeHTML("http://".$W->{"web_hostname"}."/".($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="'.path_web('/have_js.pm').'"></script>'."\n";
		}

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

	$ENV{"HOSTNAME"}||=$W->{"web_hostname"};

	return bless $W,$class;
}

# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself.
sub Wprint($%)
{
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;
}

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

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

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

# /home/user/www/webdir
sub dir_top_abs_disk()
{
	our $dir_top_abs_disk;
	if (!$dir_top_abs_disk) {
		my $selfpkg_relpath=__PACKAGE__;
		$selfpkg_relpath=~s{::}{/}g;
		$selfpkg_relpath.=".pm";
		my $selfpkg_abspath=$INC{$selfpkg_relpath} or do {
			cluck "Unable to find self package $selfpkg_relpath";
			return;
			};
		$selfpkg_abspath=~s{/*\Q$selfpkg_relpath\E$}{} or do {
			cluck "Unable to strip myself \"$selfpkg_relpath\" from the abspath: $selfpkg_abspath";
			return;
			};
		cluck "INC{myself} is relative?: $selfpkg_abspath" if $selfpkg_abspath!~m{^/};
		$dir_top_abs_disk=$selfpkg_abspath;
		}
	return $dir_top_abs_disk;
}

sub unparsed_uri()
{
	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"})."/");
		$W->{"unparsed_uri"}=$uri;
		}
	return $W->{"unparsed_uri"};
}

sub in_to_uri_abs($)
{
my($in)=@_;

	# Otherwise we may have been already processed and thus legally relativized.
	# FIXME data: Currently disabled, all the data are too violating such rule.
	if (0 && !ref $in) {
		my $uri_check=URI->new($in);
		$uri_check->scheme() || $in=~m{^\Q./\E} || $in=~m{^/}
				or cluck "Use './' or '/' prefix for all the local references: $in";
		}
	my $uri=URI->new_abs($in,unparsed_uri());
	$uri=$uri->canonical();
	return $uri;
}

# $args{"uri_as_in"}=1 to permit passing URI objects as: $in
sub path_web($%)
{
my($in,%args)=@_;

	cluck if !$args{"uri_as_in"} && ref $in;
	my $uri=in_to_uri_abs($in);
	if (uri_is_local($uri)) {
		# 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()},
				});
		}
	return $uri->abs(unparsed_uri()) if $W->{"args"}{"Wabs"} || $args{"abs"};
	return $uri->rel(unparsed_uri());
}

# $args{"uri_as_in"}=1 to permit passing URI objects as: $in
sub path_abs_disk($%)
{
my($in,%args)=@_;

	cluck if !$args{"uri_as_in"} && ref $in;
	my $uri=in_to_uri_abs($in);
	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;
}

sub fatal (;$);

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

	while (my($name,$regex)=each(%tmpl)) {
		my $name_html="Parameter <span class=\"quote\">".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\">".escapeHTML($val)."</span>"
							." does not match the required regex <span class=\"quote\">".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";

	# Do not send it unconditionally.
	# The intial duplicated '<?xml...' crashes Gecko parser.
	$W->{"heading_done"}=0 if $W->{"header_only"};
	# Do not send it unconditionally.
	# Prevents warn: Headers already sent
	if (!$W->{"heading_done"}) {
		$W->{"indexme"}=0;	# For the case no heading was sent yet.
		$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"};

	Wprint $W->{"footing_delimit"},"undef"=>1;

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

	my $packages_used=$W->{'packages_used@'}{$W->{"__PACKAGE__"}};

	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(.pm)) {
						$ext=$_;
						my $path_abs_disk=path_abs_disk("/$file$ext");
						push @tried,$path_abs_disk;
						last if -r $path_abs_disk;
						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!~/^Apache2::/ ? $package : $cvs_id_split[1]));
					$cvs_id_split[5]=&{$W->{"cvs_id_author_sub"}}($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;
		}

	Wprint $W->{"footing"},"undef"=>1;

	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 uri_is_local($)
{
my($in)=@_;

	my $uri_rel=in_to_uri_abs($in)->rel(unparsed_uri());
	# Do not: defined $uri_rel->("userinfo"|"host"|"port")();
	# as they fail to be called for schemes not supporting them.
	return 0 if $uri_rel->scheme();
	return 0 if $uri_rel->authority();
	return 1;
}

# &path_web still may be required for &uri_escaped !
sub uri_escaped($)
{
my($uri)=@_;

	cluck if !ref $uri;
	my $urient=escapeHTML($uri);
	return $uri    if $uri eq $urient;
	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()))));
}

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

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

	my $path_web=path_web $in,%args;
	my $r="";
	$r.='<a href="';
	$r.=uri_escaped $path_web;
	$r.='"';
	do { $r.=" $_" if $_; } for ($args{"attr"});
	$r.='>'.$contents.'</a>';
	if ($args{"size"} && uri_is_local($in) && ($args{"size"}>=2 || $in=~/[.](?:gz|Z|rpm|zip|deb|lha)/)) {	# Downloadable?
		my $path_abs_disk=path_abs_disk $in,%args;
		cluck "File not readable: $path_abs_disk" if !-r $path_abs_disk;
		$r.='&nbsp;('.size_display((stat($path_abs_disk))[7]).')';
		}
	return $r;
}

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

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

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

sub remote_ip ()
{
	# Do not: PerlModule                 Apache2::ForwardedFor
	#         PerlPostReadRequestHandler Apache2::ForwardedFor
	# 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*//;
	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)=@_;

	# FIXME: &alarm, --timeout is now infinite.
	# FIXME: Try to remove bash(1).
	# FIXME: Use: @PATH_FLOCK@
	my @argv=('flock',dir_top_abs_disk(),'bash','-c',$cmd.' >&2');
	print STDERR join(" ","SPAWN:",@argv)."\n";
	system @argv;
}

sub make_file($$)
{
my($self,$file)=@_;

	cluck "Pathname not absolute: $file" if $file!~m{^/};
	return if -f $file;
	# TODO: Somehow quickly check dependencies?
	return make('make -s --no-print-directory'
					.' -C '."'".File::Basename::dirname($file)."' '".File::Basename::basename($file)."'");
}

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

	cluck if !defined $width || !defined $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) ];
}

# Input: $self is required!
# Input: Put the fallback variant as the first one.
# Returns: always only scalar!
sub Negotiate_choose($$)
{
my($self,$variants)=@_;

	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.
			# Do not: $W->{"r"}->headers_in()
			# 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()}));
	$best||=$variants->[0][0];	# $variants->[0]{"id"}; &HTTP::Negotiate::choose failed?
	return $best;
}

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

# Returns: ($path_web,$path_abs_disk)
# URI path segments support ignored here. Where it is used? (';' path segment options)
sub _img_src($%)
{
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;

	# Known image extension?
	return path_web($uri,%args,"uri_as_in"=>1),$path_abs_disk if $uri->path()=~m#$img_variants_re#o;

	my @nego_variants;
	for my $var (@img_variants) {
		my $path_abs_disk_variant=$path_abs_disk.".".$var->{"id"};
		__PACKAGE__->make_file($path_abs_disk_variant);
		push @nego_variants,negotiate_variant(
				%$var,
				"size"=>(stat $path_abs_disk_variant)[7],
				);
		}
	my $ext=__PACKAGE__->Negotiate_choose(\@nego_variants);

	$uri->path($uri->path().".$ext");
	return path_web($uri,%args,"uri_as_in"=>1),path_abs_disk($uri,%args,"uri_as_in"=>1);
}

# $args{"attr"}
sub img ($$%)
{
my($in,$alt,%args)=@_;

	my($path_web,$path_abs_disk)=_img_src($in,%args);
	my($width,$height)=Image::Size::imgsize($path_abs_disk);
	$alt=~s/<[^>]*>//g;
	$alt=escapeHTML($alt);
	my $content="<img src=\"".uri_escaped($path_web)."\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
			.(!$args{"attr"} ? "" : " ".$args{"attr"})." />";
	do { return a_href((_img_src($_))[0],$content,"uri_as_in"=>1) if $_; } for $args{"a_href_img"};
	do { return a_href $_,$content if $_; } for $args{"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)=@_;

	# FIXME: Workaround bug of 'Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)':
	#        <col width="@{[ (!$W->{"browser"}->ie() ? "1*" : "90%" ) ]}" />
	#        <col width="@{[ (!$W->{"browser"}->ie() ? "0*" : "10%" ) ]}" />
	# causes whole invisible projects in: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7.10) Gecko/20050719 Galeon/1.3.21
	return <<"HERE";
<table border="0" width="100%">
	<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 cluck "Cannot open \"$filename\": $!";
	my $F=do { local $/=undef(); <F>; };
	close F or cluck "Cannot close \"$filename\": $!";
	return $F;
}

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"}->headers_out()->{$key}=$val;
		}
	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"}++;

	# 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([
			# Put the fallback variant as the first one.
			# Rate both variants the same to prefer "text/html" for undecided clients.
			# At least
			#   Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217
			# prefers "application/xhtml+xml" over "text/html" itself:
			#   text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5
			negotiate_variant(
					"id"=>"text/html",
					"content-type"=>"text/html",
					"qs"=>0.6,
					"charset"=>$client_charset,
					"lang"=>$W->{"language"},
					),
			negotiate_variant(
					"id"=>"application/xhtml+xml",
					"content-type"=>"application/xhtml+xml",
					"qs"=>0.6,
					"charset"=>$client_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"};
	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"} || ())));
	$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") ]}" />
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="'.uri_escaped(path_web $_).'" />'."\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";

	Wprint $W->{"heading"},"undef"=>1;
}

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

1;