From 40a1b03e046d727229e2272b25d0b03ceaa30803 Mon Sep 17 00:00:00 2001 From: short <> Date: Fri, 26 Sep 2003 20:30:26 +0000 Subject: [PATCH 1/1] modperl update --- Project.pm | 106 ++++++++++++++++++++++++++++++++++++++----------------------- Web.pm | 9 +++--- 2 files changed, 72 insertions(+), 43 deletions(-) diff --git a/Project.pm b/Project.pm index 4cacd84..6be4127 100644 --- a/Project.pm +++ b/Project.pm @@ -38,7 +38,7 @@ my($class,$ListItem)=@_; print $ListItem->{"description"}; print "
\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("
\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 ''."\n"; sub tableit_func { my($tableit,$val,$key,$ListItem)=@_; - print ""; - if ($tableit->{"format"}) { - my $format=$tableit->{"format"}; - my $valn=&$format($val); - $val=$valn if defined $valn; - } - print "\n"; delete $ListItem->{$key}; + my $r=""; + $r.=""; + if ($tableit->{"text"}) { + $r.=""; + } + if ($tableit->{"format"}) { + do { $val=$_ if defined $_; } for (&{$tableit->{"format"}}($val,$key)); + } + return join("",map("\n",@$val)) + if ref $val; + $r.=""; + $r.="\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 '
"; - if (!ref $tableit->{"text"}) { - print $tableit->{"text"}; - } - else { - my $textfunc=$tableit->{"text"}; - my $key=$key; - print &$textfunc($key); - } - print ":$val
"; + $r.=(!ref $_ ? $_ : &{$_}($key)) for ($tableit->{"text"}); + $r.="
".$_->[0]."".$_->[1]."
$val
'."\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 "
\n"; print vskip; } @@ -158,7 +182,11 @@ my($class,%args)=@_; $name=~s#]*>([^<]*)#$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 --- 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 ($$;%) -- 1.8.3.1