X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=e41a314f3d09e47f2d524abca9ba690d5df97d32;hp=202ecd99cc81bf03ad2fca8fa8a462fe53ec1090;hb=refs%2Fheads%2Fmodperl;hpb=c8dccbabbbd73dcf3b25bddf5e8557d7551dd6c4

diff --git a/Web.pm b/Web.pm
index 202ecd9..e41a314 100644
--- a/Web.pm
+++ b/Web.pm
@@ -23,13 +23,45 @@ our $CVS_ID=q$Id$;
 use strict;
 use warnings;
 
-use lib qw(/home/short/lib/perl5/site_perl/5.6.0/i386-linux /home/short/lib/perl5/site_perl/5.6.0 /home/short/lib/perl5/site_perl/i386-linux /home/short/lib/perl5/site_perl /home/short/lib/perl5/5.6.0/i386-linux /home/short/lib/perl5/5.6.0 /home/short/lib/perl5/i386-linux /home/short/lib/perl5);
-
 use Exporter;
-our @EXPORT=qw(&require &a_href &a_href_cz &vskip &img $W);
+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);
 our @ISA=qw(Exporter);
 
-use WebConfig;	# for %WebConfig
+BEGIN
+{
+	sub Wrequire ($)
+	{
+	my($file)=@_;
+
+#		print STDERR "Wrequire $file\n";
+		$file=~s#/#::#g;
+		$file=~s/[.]pm$//;
+		my $class=$file;
+		$file=~s#::#/#g;
+		$file.=".pm";
+		my $aref=($W->{"packages_used"}{$Apache::Registry::curstash}||=[]);
+		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
@@ -46,7 +78,7 @@ delete $ENV{"PERLLIB"};
 delete $ENV{"LD_LIBRARY_PATH"};
 
 
-our $W;
+#our $W;
 		# $W->{"title"}
 		# $W->{"head"}
 		# $W->{"head_css"}
@@ -63,7 +95,9 @@ sub init ($%)
 {
 my($class,%args)=@_;
 
+	my $packages_used_save=$W->{"packages_used"};
 	$W={ %WebConfig,%args };	# override %WebConfig settings
+	$W->{"packages_used"}=$packages_used_save;
 
 	$W->{"__PACKAGE__"}||="Apache::ROOT".$Apache::Registry::curstash;
 
@@ -72,6 +106,7 @@ my($class,%args)=@_;
 	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 ("heading");
 	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");
@@ -99,7 +134,7 @@ my($class,%args)=@_;
 		{ delete $W->{"have_ent"}; }
 	if ($W->{"detect_ent"} && !defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") {
 		$W->{"head"}.='<meta http-equiv="Refresh" content="0; URL='
-				.CGI::escapeHTML("http://".$W->{"r"}->hostname()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0]
+				.CGI::escapeHTML("http://".&{$W->{"web_hostname_sub"}}()."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0]
 						."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect')
 				.'" />'."\n";
 		}
@@ -107,8 +142,13 @@ my($class,%args)=@_;
 	$W->{"r"}->args($W->{"QUERY_STRING"});
 	$ENV{"QUERY_STRING"}=$W->{"QUERY_STRING"};
 	# Do not: $W->{"r"}->args()
-	# as it  parses only QUERY_STRING (not POST data).
+	# as it parses only QUERY_STRING (not POST data).
 	$W->{"args"}={ CGI->new()->Vars() };
+	for (keys(%{$W->{"args"}})) {
+		my @vals=split /\x00/,$W->{"args"}{$_};
+		next if @vals<=1;
+		$W->{"args"}{$_}=[@vals];
+		}
 
 	do { $W->{$_}=$ENV{"HTTP_ACCEPT"} if !defined $W->{$_}; } for ("accept");
 	do { $W->{$_}=$ENV{"HTTP_USER_AGENT"} if !defined $W->{$_}; } for ("user_agent");
@@ -121,7 +161,7 @@ my($class,%args)=@_;
 
 	$W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0);
 	if ($W->{"detect_js"} && !$W->{"have_js"}) {
-		$W->{"head"}.='<script type="text/javascript" src="'.$W->{"top_dir"}.'/have_js.js.pl"></script>'."\n";
+		$W->{"head"}.='<script type="text/javascript" src="'.top_dir('/have_js.js.pl').'"></script>'."\n";
 		}
 
 	do { args_check(%$_) if $_; } for ($W->{"args_check"});
@@ -129,20 +169,39 @@ my($class,%args)=@_;
 	return $W;
 }
 
-sub require ($)
+sub top_dir_disk ()
 {
-my($file)=@_;
-
-	$file=~s#/#::#g;
-	$file=~s/[.]pm$//;
-	my $class=$file;
-	$file=~s#::#/#g;
-	$file.=".pm";
-	my $aref=($W->{"packages_used"}{$Apache::Registry::curstash}||=[]);
-	push @$aref,$class
-			if !{ map(($_=>1),@$aref) }->{$class};	# Prevent duplicated entries.
-	CORE::require $file;
-	1;	# Otherwise 'require' would already file above.
+	do { return $_ if $_; } for ($W->{"top_dir"});
+	return $INC[0];	# fallback
+}
+
+sub top_dir (;$)
+{
+my($in)=@_;
+
+	if (my $uri=$ENV{"REQUEST_URI"}) {
+		$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 (;$);
@@ -152,13 +211,18 @@ sub args_check (%)
 my(%tmpl)=@_;
 
 	while (my($name,$regex)=each(%tmpl)) {
-		my $name_html="Parametr <span class=\"quote\">".CGI::escapeHTML($name)."</span>";
-		my $val=$W->{"args"}{$name};
-		fatal "$name_html <span class=\"quote\">".CGI::escapeHTML($val)."</span>"
-						." does not match required regex <span class=\"quote\">".CGI::escapeHTML($regex)."</span>"
-				if defined $val && $val!~/$regex/;
-		fatal "$name_html is required"
-				if !defined $val;
+		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/;
+			}
 		}
 }
 
@@ -175,7 +239,8 @@ my($msg)=@_;
 
 	$msg="UNKNOWN" if !$msg;
 
-#	heading(false/*title*/,false/*indexme*/);	# notitle is always safe, don't index the error message
+	$W->{"indexme"}=0;	# For the case no heading was sent yet.
+	My::Web->heading();
 	print "\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";
@@ -188,10 +253,14 @@ sub footer (;$)
 
 	print vskip if $W->{"footer_delimit"};
 
+	if ($W->{"heading"}) {
+		do { &{$_}() if $_; } for ($W->{"footing_delimit"});
+		}
+
 	print "<hr />\n" if $W->{"footer"};
 
 	if ($W->{"footer_mailme"}) {
-		print '<form action="'.$W->{"top_dir"}.'/SendMsg.pl" method="post" onsubmit="'
+		print '<form action="'.top_dir('/SendMsg.pl').'" method="post" onsubmit="'
 				."this.elements['msgscript'].value=this.elements['msghtml'].value;"
 				."this.elements['msghtml'].value='';"
 				."this.submit();"
@@ -222,7 +291,7 @@ sub footer (;$)
 					my $ext;
 					for (qw(.html.pl .pl .pm),"") {
 						$ext=$_;
-						last if -r $W->{"top_dir"}."/$file$ext";
+						last if -r top_dir_disk()."/$file$ext";
 						cluck "Class file $file not found" if !$ext;
 						}
 					$file.=$ext;
@@ -238,11 +307,26 @@ sub footer (;$)
 			} (
 					$W->{"__PACKAGE__"},
 					__PACKAGE__,
-					"WebConfig",
 					@{$W->{"packages_used"}{$Apache::Registry::curstash}},
 					)));
 		print "</p>\n";
 		}
+
+	for my $package (
+			$W->{"__PACKAGE__"},
+			__PACKAGE__,
+			@{$W->{"packages_used"}{$Apache::Registry::curstash}},
+			) {
+		my $cvs_id=(eval('$'.$package."::CVS_ID")
+#				|| $package	# debug
+				);
+		print '<!-- '.$package.' - $'.$cvs_id.'$ -->'."\n" if $cvs_id;
+		}
+
+	if ($W->{"heading"}) {
+		do { &{$_}() if $_; } for ($W->{"footing"});
+		}
+
 	print "</body></html>\n";
 	exit(0);
 }
@@ -286,8 +370,12 @@ sub a_href ($;$%)
 {
 my($url,$contents,%args)=@_;
 
-	do { $$_=1 if !defined $$_; } for ($args{"size"});
+	do { $$_=1 if !defined $$_; } for (\$args{"size"});
 	$contents=CGI::escapeHTML($url) if !defined $contents;
+	$contents=~s#<a\b[^>]*>##gi;
+	$contents=~s#</a>##gi;
+
+	$url=top_dir($url) if url_is_local $url && $url=~m#^/#;
 
 	my $r='<a href="';
 	my $urlent=CGI::escapeHTML($url);
@@ -300,9 +388,12 @@ my($url,$contents,%args)=@_;
 	elsif ($W->{"have_ent"})	# ent client
 		{ $r.=$urlent; }
 	else	# unknown client, &CGI::escapeHTML should not be needed here
-		{ $r.=CGI::escapeHTML("http://".$W->{"r"}->hostname()."/Redirect.pl?location=".uri_escape($url)); }
-	$r.='">'.$contents.'</a>';
-	if ($args{"size"} && url_is_local($url) && $url=~/[.](?:gz|rpm|zip|deb)/) {	# Downloadable?
+		{ $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) && $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 {
@@ -319,14 +410,13 @@ sub remote_ip ()
 	# 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=$ENV{"HTTP_X_FORWARDED_FOR"} || $W->{"r"}->remote_host();
+	my $r=$ENV{"HTTP_X_FORWARDED_FOR"} || $W->{"r"}->get_remote_host();
 	$r=~s/^.*,\s*//;
 	return $r;
 }
 
 sub is_cz ()
 {
-print STDERR "IP=".remote_ip()."\n";
 	return "CZ" eq Geo::IP->new()->country_code_by_addr(remote_ip());
 }
 
@@ -338,6 +428,13 @@ my($url,$contents,%args)=@_;
 	return $contents;
 }
 
+sub make ($)
+{
+my($cmd)=@_;
+
+	system {'flock'} 'flock','-x',top_dir_disk(),$cmd.' >&2';
+}
+
 sub img_size ($$)
 {
 my($width,$height)=@_;
@@ -358,23 +455,40 @@ 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('|',map(($_->{"id"}),@img_variants)).')$';
+my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$';
 
 sub img_src ($)
 {
 my($file_base)=@_;
 
-	return $file_base if !url_is_local($file_base)
-			# Known image extension?
-			|| $file_base=~m#$img_variants_re#o;
+	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.".".$var->{"id"};
+		my $file=$file_base_disk.".".$var->{"id"};
 		# TODO: Somehow quickly check dependencies?
-		system 'make >&2 -s --no-print-directory'
-						.' -C '."'".File::Basename::dirname($file)."' '".File::Basename::basename($file)."'";
-#				if !-f $file;
+		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],
@@ -384,18 +498,57 @@ my($file_base)=@_;
 	# 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.".".$ext;
+
+	return $file_base_uri.".".$ext if !wantarray();
+	return ($file_base_uri.".".$ext,$file_base_disk.".".$ext);
 }
 
-sub img ($$;$)
+sub img ($$;%)
 {
-my($file_base,$alt,$attrs)=@_;
+my($file_base,$alt,%attr)=@_;
 
-	my $file=img_src $file_base;
-	my($width,$height)=Image::Size::imgsize($file);
+	my($file_uri,$file_disk)=img_src $file_base;
+	my($width,$height)=Image::Size::imgsize($file_disk);
+	$alt=~s/<[^>]*>//g;
 	$alt=CGI::escapeHTML($alt);
-	return "<img src=\"$file\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
-			.(!$attrs ? "" : " ".$attrs)." />";
+	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 ($$)
@@ -426,6 +579,8 @@ sub heading ()
 {
 my($class)=@_;
 
+	return if $W->{"heading_passed"}++;
+
 	# $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!)
 	my $client_charset=$W->{"force_charset"} || "us-ascii";
 	header("Content-Style-Type"=>"text/css");
@@ -444,9 +599,10 @@ my($class)=@_;
 		}
 	print '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">'."\n";
 	print '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en-US">'."\n";
-	print '<head><title>'.CGI::escapeHTML($W->{"title_prefix"})
-			.join("",map({ ': '.CGI::escapeHTML($_); } ($W->{"title"} || ())))
-			.'</title>'."\n";
+	my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ())));
+	$title=~s#<[^>]*>##g;
+	print "<head>";
+	print "<title>$title</title>\n";
 
 	if ($W->{"have_css"}) {
 		print <<'HERE';
@@ -475,10 +631,17 @@ HERE
 
 	print '<meta name="robots" content="'.($W->{"indexme"} ? "" : "no" ).'index,follow" />'."\n";
 	print $W->{"head"};
+	for my $type (qw(prev next index contents start up)) {
+		do { print '<link rel="'.$type.'" href="'.$_.'" />'."\n" if $_; } for ($W->{"rel_$type"});
+		}
 	print "</head><body";
 	print ' bgcolor="black" text="white" link="aqua" vlink="teal"'
 			if $W->{"browser"}->netscape() && $W->{"browser"}->major<=4;
 	print ">\n";
+
+	if ($W->{"heading"}) {
+		do { &{$_}() if $_; } for ($W->{"heading"});
+		}
 }
 
 1;