X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;fp=Web.pm;h=35bdb386a0d361caac4fe359d57c70f12c6bba64;hp=885620df5ae3b0ee530d2e735e54a8f1f9c784c1;hb=aba10a49c1e0d87b131388fe7b7342bf87a6a539;hpb=6a26dcbc13f70543517060e58e0eaced7847a535

diff --git a/Web.pm b/Web.pm
index 885620d..35bdb38 100644
--- a/Web.pm
+++ b/Web.pm
@@ -156,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="'.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"});
@@ -170,16 +170,33 @@ sub top_dir_disk ()
 	return $INC[0];	# fallback
 }
 
-sub top_dir ()
+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);
-		return $uri;
+		my $r=$uri.(defined $in ? $in : "");
+#		1 while $r=~s#^[.]/##;
+#		$r="./$r" if $r=~m#^(?:?.*)$#;	# empty pathname?
+		return $r;
 		}
-	return top_dir_disk();
+	return top_dir_disk().$in;
 }
 
 sub fatal (;$);
@@ -228,7 +245,7 @@ sub footer (;$)
 	print "<hr />\n" if $W->{"footer"};
 
 	if ($W->{"footer_mailme"}) {
-		print '<form action="'.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();"
@@ -259,7 +276,7 @@ sub footer (;$)
 					my $ext;
 					for (qw(.html.pl .pl .pm),"") {
 						$ext=$_;
-						last if -r top_dir()."/$file$ext";
+						last if -r top_dir_disk()."/$file$ext";
 						cluck "Class file $file not found" if !$ext;
 						}
 					$file.=$ext;
@@ -343,6 +360,8 @@ my($url,$contents,%args)=@_;
 	$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);
 	   if ($url eq $urlent)
@@ -354,11 +373,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(top_dir()."/Redirect.pl?location=".uri_escape($url)); }
+		{ $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 {
@@ -419,13 +439,26 @@ sub img_src ($)
 {
 my($file_base)=@_;
 
-	return $file_base if !url_is_local($file_base)
+	if (!url_is_local($file_base)
 			# Known image extension?
-			|| $file_base=~m#$img_variants_re#o;
+			|| $file_base=~m#$img_variants_re#o) {
+		return $file_base if !wantarray();
+		return ($file_base,$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)."'"
@@ -439,18 +472,20 @@ 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 ($$;$)
 {
 my($file_base,$alt,$attrs)=@_;
 
-	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)
+	return "<img src=\"$file_uri\" alt=\"$alt\" title=\"$alt\" ".img_size($width,$height)
 			.(!$attrs ? "" : " ".$attrs)." />";
 }