modperl update

diff --git a/Project.pm b/Project.pm
index 4cacd84..6be4127 100644 (file)
--- a/Project.pm
+++ b/Project.pm
@@ -38,7 +38,7 @@ my($class,$ListItem)=@_;
        print $ListItem->{"description"};
        print "<hr />\n";
        my @table=(
-               {"key"=>qr(^download\b.*),"text"=>sub ($) {
+               {"key"=>qr(^download\b),"text"=>sub ($) {
                                                $_[0]=~s/^download//;
                                                $_[0]=~s/^-/ /;
                                                return "Download".$_[0];
@@ -59,13 +59,31 @@ my($class,$ListItem)=@_;
                                                        }
                                                return $r;
                                                }},
-               {"key"=>qr(^link\b.*),"text"=>sub ($) {
+               {"key"=>qr(^link\b),"text"=>sub ($) {
                                                $_[0]=~s/^link-//;
                                                return $_[0];
                                                },
                                "format"=>sub ($) {
                                                return a_href($_[0],CGI::escapeHTML($_[0]));
                                                }},
+               {"key"=>qr(^cvs\b),"text"=>sub ($) {
+                                               $_[0]=~s/^cvs//;
+                                               $_[0]=~s/^-/ /;
+                                               return "CVS".$_[0];
+                                               },
+                               "format"=>sub ($$) {
+                                               my($val,$key)=@_;
+                                               $key=~s/^cvs//;
+                                               $key=~s/^-/ /;
+                                               my $branch="";
+                                               $branch="only_with_tag=$1" if $val=~s/:(.*)//;
+                                               return join("<br />\n\t\t",map({ a_href($_->[1],$_->[0]); }
+                                                               ["ViewCVS CVS repository",$W->{"project_viewcvs"}.$val."/".(!$branch ? '' : '?'.$branch)],
+                                                               ["Download CVS snapshot" ,
+                                                                               $W->{"project_viewcvs"}.$val."/".File::Basename::basename($val).".tar.gz?tarball=1"
+                                                                                               .(!$branch ? '' : '&'.$branch)],
+                                                               ["CVS ChangeLog"         ,$W->{"top_dir"}."/project/ChangeLog.txt.pl?cvs=$val"]));
+                                               }},
                {"key"=>"summary","text"=>"Summary"},
                {"key"=>"ownership","text"=>"Ownership"},
                {"key"=>"license","text"=>"License","format"=>sub ($) {
@@ -73,21 +91,28 @@ my($class,$ListItem)=@_;
                                                "PD"=>"Public Domain",
                                                "GPL"=>a_href("http://www.gnu.org/licenses/gpl.html","GNU General Public License"),
                                                "LGPL"=>a_href("http://www.gnu.org/licenses/lgpl.html","GNU Lesser General Public License"),
+                                               "com"=>"Commercial"
                                                );
                                return $known{$_[0]};
                                }},
-               {"key"=>"maintenance","text"=>"Currently maintained?","format"=>sub ($) {
+               {"key"=>"maintenance","text"=>"State","format"=>sub ($) {
                                my %known=(
-                                               "finished"=>"Project is finished. Possible bug reports welcome although project not actively developed.",
-                                               "dead"=>"Project became dead code, some updates would be required. It is no longer used, project is not supported.",
-                                               "obsolete"=>"Obsolete as some other existing package superseded this one.",
-                                               "merge"=>"Functions of this package should be merged to some other one.",
-                                               "update"=>"Package needs updating to be fully usable, patches welcome.",
-                                               "accepted"=>"This patch was accepted by the original package author. It has no longer any separate meaning.",
+                                               "active"=>"Ready to use and the package is being actively developed.",
+                                               "ready"=>"Ready to use although no longer being actively developed.",
+                                               "dead"=>"Dead code, no longer supported.",
+                                               "merge"=>"Functions belong to existing other project.",
+                                               "obsolete"=>"Obsoleted.",
+                                               "update"=>"Package needs updating to recent software.",
+                                               "accepted"=>"This patch got already integrated by the original package maintainer.",
+                                               ""=>"",
                                                );
-                               return $known{$_[0]};
+                               my @r;
+                               for ($known{($_[0]=~/^([^-]*)-?/)[0] || ""}) {
+                                       push @r,$_ if $_;
+                                       push @r," $'" if $';
+                                       }
+                               return join(" ",@r);
                                }},
-               {"key"=>"reason","text"=>"Reason"},
                {"key"=>"sponsorship","text"=>"Sponsoring Company"},
                {"key"=>"language","text"=>"Programming language","format"=>sub ($) {
                                return a_href("http://java.sun.com/",CGI::escapeHTML($_[0]))
@@ -97,43 +122,42 @@ my($class,$ListItem)=@_;
                                return undef();
                                }},
                );
-       print '<table border="0">'."\n";
 
 sub tableit_func
 {
 my($tableit,$val,$key,$ListItem)=@_;
 
-       print "<tr><td>";
-       if (!ref $tableit->{"text"}) {
-               print $tableit->{"text"};
-               }
-       else {
-               my $textfunc=$tableit->{"text"};
-               my $key=$key;
-               print &$textfunc($key);
-               }
-       print ":</td>";
-       if ($tableit->{"format"}) {
-               my $format=$tableit->{"format"};
-               my $valn=&$format($val);
-               $val=$valn if defined $valn;
-               }
-       print "<td>$val</td></tr>\n";
        delete $ListItem->{$key};
+       my $r="";
+       $r.="<tr>";
+               if ($tableit->{"text"}) {
+                       $r.="<td>";
+                               $r.=(!ref $_ ? $_ : &{$_}($key)) for ($tableit->{"text"});
+                       $r.="</td>";
+                       }
+               if ($tableit->{"format"}) {
+                       do { $val=$_ if defined $_; } for (&{$tableit->{"format"}}($val,$key));
+                       }
+               return join("",map("<tr><td>".$_->[0]."</td><td>".$_->[1]."</td></tr>\n",@$val))
+                               if ref $val;
+               $r.="<td>$val</td>";
+       $r.="</tr>\n";
 }
 
-       for my $tableit (@table) {
-               if (!ref $tableit->{"key"}) {
-                       tableit_func($tableit,$ListItem->{$tableit->{"key"}},$tableit->{"key"},$ListItem) if $ListItem->{$tableit->{"key"}};
-                       }
-               else {
-                       for my $key (@{$ListItem->{"keys_array"}}) {
-                               my $keyregex=$tableit->{"key"};
-                               next if $key!~/$keyregex/;
-                               tableit_func($tableit,$ListItem->{$key},$key,$ListItem);
+       print '<table border="0" class="print_project">'."\n";
+               for my $tableit (@table) {
+                       if (!ref $tableit->{"key"}) {
+                               print tableit_func($tableit,$ListItem->{$tableit->{"key"}},$tableit->{"key"},$ListItem)
+                                               if $ListItem->{$tableit->{"key"}};
+                               }
+                       else {
+                               for my $key (@{$ListItem->{"keys_array"}}) {
+                                       my $keyregex=$tableit->{"key"};
+                                       next if $key!~/$keyregex/;
+                                       print tableit_func($tableit,$ListItem->{$key},$key,$ListItem);
+                                       }
                                }
                        }
-               }
        print "</table>\n";
        print vskip;
 }
@@ -158,7 +182,11 @@ my($class,%args)=@_;
        $name=~s#<a\s[^>]*>([^<]*)</a>#$1#g;
        my $W=$class->init(
                        "title"=>$name,
-                       %args);
+                       %args,
+                       "head_css"=>($args{"head_css"} || "")."
+table.print_project td { vertical-align: top; }
+",
+                       );
        $class->heading();
        $class->print_project({ %$ListItem });
        return $W;

diff --git a/Web.pm b/Web.pm
index 60f5c72..7eacfa0 100644 (file)
--- a/Web.pm
+++ b/Web.pm
@@ -26,7 +26,7 @@ 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);
+our @EXPORT=qw(&require &a_href &a_href_cz &vskip &img $W);
 our @ISA=qw(Exporter);
 
 use WebConfig; # for %WebConfig
@@ -37,6 +37,7 @@ use Carp qw(cluck confess);
 use URI::Escape;
 require HTTP::BrowserDetect;
 require HTTP::Negotiate;
+require Geo::IP;
 
 
 # Undo 'www/engine/httpd-restart' as it may use obsolete Perl for 'mod_perl'
@@ -44,7 +45,7 @@ delete $ENV{"PERLLIB"};
 delete $ENV{"LD_LIBRARY_PATH"};
 
 
-my $W;
+our $W;
                # $W->{"title"}
                # $W->{"head"}
                # $W->{"head_css"}
@@ -260,7 +261,7 @@ my($url,$contents,%args)=@_;
        my $urlent=CGI::escapeHTML($url);
           if ($url eq $urlent)
                { $r.=$url; }
-       elsif ($url!~m#^[a-z]+://#)     # $url is our resource
+       elsif (url_is_local $url)
                { $r.=$urlent; }
        elsif (defined $W->{"have_ent"} && !$W->{"have_ent"})   # non-ent client
                { $r.=$url; }
@@ -281,7 +282,7 @@ my($url,$contents,%args)=@_;
 
 sub is_cz ()
 {
-       return $W->{"r"}->get_remote_host()=~/[.]cz$/i;
+       return "CZ" eq Geo::IP->new()->country_code_by_addr($W->{"r"}->get_remote_host());
 }
 
 sub a_href_cz ($$;%)