URL relativization.

diff --git a/Project.pm b/Project.pm
index 2226a64..13a8d95 100644 (file)
--- a/Project.pm
+++ b/Project.pm
@@ -113,7 +113,7 @@ my($class,$ListItem)=@_;
                                                                                                ["Download CVS snapshot" ,
                                                                                                                $W->{"project_viewcvs"}.$val."/".File::Basename::basename($val).".tar.gz?tarball=1"
                                                                                                                                .(!$branch ? "" : '&only_with_tag='.$branch)],
-                                                                                               ["CVS ChangeLog"         ,top_dir()."/project/ChangeLog.txt.pl?cvs=$val"])));
+                                                                                               ["CVS ChangeLog"         ,"/project/ChangeLog.txt.pl?cvs=$val"])));
                                                }},
                {"key"=>"ownership","text"=>"Ownership"},
                {"key"=>"sponsorship","text"=>"Sponsorship"},
@@ -247,10 +247,10 @@ my($class,$view_selected)=@_;
 <h1>Project List of @{[ a_href 'http://www.jankratochvil.net/','Jan Kratochvil' ]}</h1>
 
 <ul>
-       <li>@{[ &{$view}('Detailed'     ,top_dir().'/project/','Detailed project listing per platform') ]}</li>
-       <li>@{[ &{$view}('BriefPlatform',top_dir().'/project/List.html.pl?platform=platform',
+       <li>@{[ &{$view}('Detailed'     ,'/project/','Detailed project listing per platform') ]}</li>
+       <li>@{[ &{$view}('BriefPlatform','/project/List.html.pl?platform=platform',
                        'Brief project listing per platform') ]}</li>
-       <li>@{[ &{$view}('BriefUnified' ,top_dir().'/project/List.html.pl',
+       <li>@{[ &{$view}('BriefUnified' ,'/project/List.html.pl',
                        'Unified brief project listing') ]}</li>
 </ul>
 @{[ vskip "1ex" ]}
@@ -273,7 +273,7 @@ my($class,$platform_selected)=@_;
                                                my $platform_name=shift @platforms;
                                                my $chosen=($platform_selected && $platform_selected eq $platform_sym);
                                                $r.='<td style="padding: 5px;">';
-                                                       $r.=a_href((!$platform_selected ? "" : top_dir()."/project/").'#'.$platform_sym,$platform_name,
+                                                       $r.=a_href((!$platform_selected ? "" : "/project/").'#'.$platform_sym,$platform_name,
                                                                        "attr"=>($chosen
                                                                                        ? 'style="text-decoration: underline; font-weight: bold;"'
                                                                                        : 'style="text-decoration: inherit; /* revoke underline */"'));

diff --git a/Web.pm b/Web.pm
index 885620d..35bdb38 100644 (file)
--- 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)." />";
 }