X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=41aaef2921ac668a08ac37e020466b334fd973db;hb=a8f5baca6ea81b99e9389f2918c75fd6f514b809;hp=b166e7611777113a0d4620d607c1fdcfeb55e52e;hpb=d283af4f7bd7659deae058ab1e07ee06ffd114b8;p=MyWeb.git

diff --git a/Web.pm b/Web.pm
index b166e76..41aaef2 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 $W &top_dir);
 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
@@ -38,6 +70,7 @@ use URI::Escape;
 require HTTP::BrowserDetect;
 require HTTP::Negotiate;
 require Geo::IP;
+require CGI;
 
 
 # Undo 'www/engine/httpd-restart' as it may use obsolete Perl for 'mod_perl'
@@ -45,7 +78,7 @@ delete $ENV{"PERLLIB"};
 delete $ENV{"LD_LIBRARY_PATH"};
 
 
-our $W;
+#our $W;
 		# $W->{"title"}
 		# $W->{"head"}
 		# $W->{"head_css"}
@@ -62,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;
 
@@ -71,12 +106,23 @@ 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");
 	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 ("head_css");
 
+	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() || "";
@@ -94,7 +140,10 @@ my($class,%args)=@_;
 		}
 	$W->{"QUERY_STRING"}=~s/([&])amp;/$1/g;
 	$W->{"r"}->args($W->{"QUERY_STRING"});
-	$W->{"args"}={ $W->{"r"}->args() };
+	$ENV{"QUERY_STRING"}=$W->{"QUERY_STRING"};
+	# Do not: $W->{"r"}->args()
+	# as it  parses only QUERY_STRING (not POST data).
+	$W->{"args"}={ CGI->new()->Vars() };
 
 	do { $W->{$_}=$ENV{"HTTP_ACCEPT"} if !defined $W->{$_}; } for ("accept");
 	do { $W->{$_}=$ENV{"HTTP_USER_AGENT"} if !defined $W->{$_}; } for ("user_agent");
@@ -107,7 +156,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"});
@@ -115,20 +164,10 @@ my($class,%args)=@_;
 	return $W;
 }
 
-sub require ($)
+sub top_dir ()
 {
-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 fatal (;$);
@@ -140,7 +179,8 @@ 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 does not match required regex <span class=\"quote\">".CGI::escapeHTML($regex)."</span>"
+		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;
@@ -171,10 +211,26 @@ sub footer (;$)
 {
 	exit 1 if $W->{"footer_passed"}++;	# deadlock prevention:
 
-	if ($W->{"footer_ids"}) {
-		print vskip if $W->{"footer_delimit"};
-		print '<hr /><p class="cvs-id">';
+	print vskip if $W->{"footer_delimit"};
+
+	print "<hr />\n" if $W->{"footer"};
+
+	if ($W->{"footer_mailme"}) {
+		print '<form action="'.top_dir().'/SendMsg.pl" method="post" onsubmit="'
+				."this.elements['msgscript'].value=this.elements['msghtml'].value;"
+				."this.elements['msghtml'].value='';"
+				."this.submit();"
+				.'">'."\n";
+			print '<p align="right">'."\n";
+				print '<input name="msgscript" type="hidden" />'."\n";
+				print '<input name="msghtml" type="text" size="32" alt="Message" />'."\n";
+				print '<input name="submit" type="submit" value="Quick Note" />'."\n";
+			print '</p>'."\n";
+		print '</form>'."\n";
+		}
 
+	if ($W->{"footer_ids"}) {
+		print '<p class="cvs-id">';
 		print join("<br />\n",map({ my $package=$_;
 			my $cvs_id=(eval('$'.$package."::CVS_ID")
 #					|| $package	# debug
@@ -191,7 +247,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()."/$file$ext";
 						cluck "Class file $file not found" if !$ext;
 						}
 					$file.=$ext;
@@ -211,6 +267,11 @@ sub footer (;$)
 					)));
 		print "</p>\n";
 		}
+
+	if ($W->{"heading"}) {
+		do { &{$_}() if $_; } for ($W->{"footing"});
+		}
+
 	print "</body></html>\n";
 	exit(0);
 }
@@ -254,7 +315,7 @@ 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;
 
 	my $r='<a href="';
@@ -268,9 +329,9 @@ 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.=CGI::escapeHTML(top_dir()."/Redirect.pl?location=".uri_escape($url)); }
 	$r.='">'.$contents.'</a>';
-	if ($args{"size"} && url_is_local($url) && $url=~/[.](?:gz|rpm|zip|deb)/) {	# Downloadable?
+	if ($args{"size"} && url_is_local($url) && $url=~/[.](?:gz|Z|rpm|zip|deb|lha)/) {	# Downloadable?
 		if (!-r $url)
 			{ cluck "File not readable: $url"; }
 		else {
@@ -287,14 +348,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());
 }
 
@@ -328,35 +388,40 @@ my @img_variants=(
 		);
 my $img_variants_re='[.](?:'.join('|',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;
+
+	my @nego_variants;
+	for my $var (@img_variants) {
+		my $file=$file_base.".".$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;
+		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.".".$ext;
+}
+
 sub img ($$;$)
 {
 my($file_base,$alt,$attrs)=@_;
 
-	my $file;
-	if (url_is_local($file_base)
-			# No known image extension?
-			&& $file_base!~m#$img_variants_re#o) {
-		my @nego_variants;
-		for my $var (@img_variants) {
-			$file=$file_base.".".$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;
-			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?
-		$file=$file_base.".".$ext;
-		}
-	else
-		{ $file=$file_base; }
+	my $file=img_src $file_base;
 	my($width,$height)=Image::Size::imgsize($file);
+	$alt=~s/<[^>]*>//g;
 	$alt=CGI::escapeHTML($alt);
 	return "<img src=\"$file\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
 			.(!$attrs ? "" : " ".$attrs)." />";
@@ -393,6 +458,7 @@ 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");
 
 	while (my($key,$val)=each(%{$W->{"headers"}})) {
 		$W->{"r"}->header_out($key,$val);
@@ -429,6 +495,7 @@ body {
 :visited { color: teal;   background-color: transparent; }
 h1,h2    { color: yellow; background-color: transparent; }
 td       { padding: 2px; }
+caption  { caption-side: bottom; }
 .footer img { vertical-align: middle; }
 HERE
 		print $W->{"head_css"}."\n";
@@ -441,6 +508,10 @@ HERE
 	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;