From: short <> Date: Sun, 21 Aug 2005 07:27:55 +0000 (+0000) Subject: Initial mod_perl-2.0 port. X-Git-Url: https://git.jankratochvil.net/?p=MyWeb.git;a=commitdiff_plain;h=4cd6b19ddd7d185a7b56d1f3de77e5646917bc48 Initial mod_perl-2.0 port. --- diff --git a/Hash/Makefile.am b/Hash/Makefile.am new file mode 100644 index 0000000..7e550dd --- /dev/null +++ b/Hash/Makefile.am @@ -0,0 +1,26 @@ +# $Id$ +# automake source for the Makefile of My/Hash/ subdir +# Copyright (C) 2005 Jan Kratochvil +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; exactly version 2 of June 1991 is required +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +include $(top_srcdir)/Makefile-head.am + +SUBDIRS= \ + Sub + +EXTRA_DIST+= \ + Sub.pm + diff --git a/Hash/Sub.pm b/Hash/Sub.pm new file mode 100644 index 0000000..9fa5fd7 --- /dev/null +++ b/Hash/Sub.pm @@ -0,0 +1,40 @@ +# $Id$ +# Hash tied to optionally dynamically generate its values +# Copyright (C) 2005 Jan Kratochvil +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; exactly version 2 of June 1991 is required +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +package My::Hash::Sub; +our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; +our $CVS_ID=q$Id$; +use strict; +use warnings; +require Tie::Hash; # for Tie::StdHash +our @ISA=qw(Tie::StdHash); +use Carp qw(cluck confess); + + +sub FETCH($$) +{ +my($this,$key)=@_; + + my $val=$this->SUPER::FETCH($key); + return $val if $key=~/_sub$/; # force + return $val if !defined $val; # 1-item array is intentional. + return $val if "CODE" ne ref $val; + return &{$val}($this,$key); +} + +1; diff --git a/Hash/Sub/Makefile.am b/Hash/Sub/Makefile.am new file mode 100644 index 0000000..3ea0c64 --- /dev/null +++ b/Hash/Sub/Makefile.am @@ -0,0 +1,23 @@ +# $Id$ +# automake source for the Makefile of My/Hash/Readonly/ subdir +# Copyright (C) 2005 Jan Kratochvil +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; exactly version 2 of June 1991 is required +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +include $(top_srcdir)/Makefile-head.am + +EXTRA_DIST+= \ + Readonly.pm + diff --git a/Hash/Sub/Readonly.pm b/Hash/Sub/Readonly.pm new file mode 100644 index 0000000..ad829a9 --- /dev/null +++ b/Hash/Sub/Readonly.pm @@ -0,0 +1,46 @@ +# $Id$ +# Hash tied to optionally dynamically generate its values and being locked/readonly +# Copyright (C) 2005 Jan Kratochvil +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; exactly version 2 of June 1991 is required +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +package My::Hash::Sub::Readonly; +our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; +our $CVS_ID=q$Id$; +use strict; +use warnings; + +use My::Web; # for &Wrequire +use Carp qw(cluck confess); + +Wrequire 'My::Hash::Sub'; +our @ISA=qw(My::Hash::Sub); + + +# Implementation reason: &Hash::Util::lock_hash does not work for tied hashes! + + +sub TIEHASH($@) +{ +my($class,@list)=@_; + + return bless {@list},$class; +} + +sub STORE { confess "READ-ONLY requirement violation"; } +sub DELETE { confess "READ-ONLY requirement violation"; } +sub CLEAR { confess "READ-ONLY requirement violation"; } + +1; diff --git a/Makefile.am b/Makefile.am index 841a425..63b0901 100644 --- a/Makefile.am +++ b/Makefile.am @@ -1,6 +1,6 @@ # $Id$ -# automake source for the Makefile of project/ subdir -# Copyright (C) 2003 Jan Kratochvil +# automake source for the Makefile of My::Web "My/" subdir +# Copyright (C) 2003-2005 Jan Kratochvil # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by @@ -18,9 +18,13 @@ include $(top_srcdir)/Makefile-head.am +SUBDIRS= \ + Hash + EXTRA_DIST+= \ - Project.pm \ Web.pm \ + ModPerlPm.pm \ arrow-left.png \ arrow-right.png \ arrow-up.png + diff --git a/ModPerlPm.pm b/ModPerlPm.pm new file mode 100644 index 0000000..7d7bf89 --- /dev/null +++ b/ModPerlPm.pm @@ -0,0 +1,65 @@ +# $Id$ +# Handle the set of ".pm" files for mod_perl +# Copyright (C) 2005 Jan Kratochvil +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; exactly version 2 of June 1991 is required +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +package My::ModPerlPm; +require 5.6.0; # at least 'use warnings;' but we need some 5.6.0+ modules anyway +our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; +our $CVS_ID=q$Id$; +use strict; +use warnings; + +use Carp qw(cluck confess); + +use Exporter; +our @EXPORT=qw(); +our @ISA=qw(Exporter); + + +# $args{"sub"}=sub { $_[0]->{"module"...}; }; +sub list($%) +{ +my($self,%args)=@_; + + my $filename="make -s MODPERL_PM-print|"; + local *F; + open F,$filename or confess "$filename: $!"; + local $_; + my @r; + while () { + next if !s/^MODPERL_PM:([^:]+)://; + my $subdir=$1; + for (split) { + my %r; + $r{"url"}=$subdir."/".$_; + $r{"url"}=~s{^[.](/.*[.]pm)$}{$1} or confess "Invalid project: subdir=$subdir base=$_"; + $r{"module"}=$r{"url"}; + $r{"module"}=~s{^/}{} or confess "Relative module: ".$r{"module"}; + $r{"file"}=$r{"module"}; + $r{"module"}=~s{/}{::}g; + $r{"module"}=~s{[.]pm$}{} or confess; + -r $r{"file"} or do { warn "FIXME: Non-existing file \"".$r{"file"}."\" for URL: ".$r{"url"}; next; }; + do { &{$_}(\%r) if $_; } for $args{"sub"}; + push @r,\%r; + } + } + close F or confess "$filename: $!"; + cluck "No modules?" if !@r; + return @r; +} + +1; diff --git a/Project.pm b/Project.pm deleted file mode 100644 index bbcee8a..0000000 --- a/Project.pm +++ /dev/null @@ -1,353 +0,0 @@ -# $Id$ -# Common functions for HTML/XHTML output generation -# Copyright (C) 2003 Jan Kratochvil -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU General Public License as published by -# the Free Software Foundation; exactly version 2 of June 1991 is required -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU General Public License for more details. -# -# You should have received a copy of the GNU General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -package My::Project; -require 5.6.0; # at least 'use warnings;' but we need some 5.6.0+ modules anyway -our $VERSION=do { my @r=(q$Revision$=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; }; -our $CVS_ID=q$Id$; -use strict; -use warnings; - -use My::Web; -require CGI; - -use Exporter; -our @EXPORT=qw(); -our @ISA=qw(My::Web Exporter); - - -sub ENTRIES { return top_dir_disk()."/project/CVS/Entries"; } -sub ENTRIES_LOG { return top_dir_disk()."/project/CVS/Entries.Log"; } - - -sub print_project -{ -my($class,$ListItem,%args)=@_; - - print "

".$W->{"title"}."

\n"; - do { print $_ if $_; } for ($args{"project_text_after_title"}); - print $ListItem->{"description"}; - print "
\n"; - print $args{"before_project_data"} || ""; - return if $args{"no_project_data"}; - my @table=( - {"key"=>"summary","text"=>"Summary"}, - {"key"=>"license","text"=>"License","format"=>sub ($) { - my %known=( - "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"=>"State","format"=>sub ($) { - my %known=( - "active"=>"Ready to use. Project is now actively developed.", - "ready"=>"Ready to use. Maintained.", - "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.", - "pending"=>"Patch is ready to be applied to the mainstream.", - "ignored"=>"Patch was ignored. It is not applied in the mainstream.", - ""=>"", - ); - my @r; - for ($known{($_[0]=~/^([^-]*)-?/)[0] || ""}) { - push @r,$_ if $_; - push @r," $'" if $'; - } - return join(" ",@r); - }}, - {"key"=>"aminet","text"=>a_href('http://www.aminet.net/','Aminet'),"format"=>sub ($) { - return join(" ", - a_href('http://www.aminet.net/'.$_[0].".lha",$_[0].".lha"), - "(".a_href('http://www.aminet.net/'.$_[0].".readme","readme").")"); - }}, - {"key"=>qr(^download\b),"text"=>sub ($) { - $_[0]=~s/^download//; - $_[0]=~s/^-/ /; - return "Download".$_[0]; - }, - "format"=>sub ($) { - return a_href($_[0],CGI::escapeHTML(File::Basename::basename($_[0])),"size"=>2); - }}, - {"key"=>qr(^link\b),"text"=>sub ($) { - $_[0]=~s/^link-//; - return $_[0]; - }, - "format"=>sub ($) { - return($_[0]=~/^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=$1 if $val=~s/:(.*)//; - return join("
\n\t\t", - CGI::escapeHTML("cvs -d ".$W->{"pserver"}.":".$W->{"pserver_path"}." -z3" - ." checkout".(!$branch ? "" : " -r $branch -kk") - .($val!~m#/# ? "" : " -d ".File::Basename::basename($val)) - ." $val"), - join(" | \n\t\t", - map({ a_href($_->[1],$_->[0]); } - ["ViewCVS CVS repository",$W->{"project_viewcvs"}.$val."/".(!$branch ? "" : '?only_with_tag='.$branch)], - ["Download CVS snapshot" , - $W->{"project_viewcvs"}.$val."/".File::Basename::basename($val).".tar.gz?tarball=1" - .(!$branch ? "" : '&only_with_tag='.$branch)], - ["CVS ChangeLog" ,"/project/ChangeLog.txt.pl?cvs=$val"]))); - }}, - {"key"=>"ownership","text"=>"Ownership"}, - {"key"=>"sponsorship","text"=>"Sponsorship"}, - {"key"=>"language","text"=>"Programming language","format"=>sub ($) { - return a_href("http://java.sun.com/",CGI::escapeHTML($_[0])) - if $_[0]=~/^Java\b/; - return a_href("http://www.php.net/",CGI::escapeHTML($_[0])) - if $_[0]=~/^PHP\b/; - return undef(); - }}, - ); - -sub tableit_func -{ -my($tableit,$val,$key,$ListItem)=@_; - - delete $ListItem->{$key}; - my $r=""; - $r.=""; - if ($tableit->{"text"}) { - $r.=""; - $r.=(!ref $_ ? $_ : &{$_}($key)) for ($tableit->{"text"}); - $r.=""; - } - if ($tableit->{"format"}) { - do { $val=$_ if defined $_; } for (&{$tableit->{"format"}}($val,$key)); - } - return join("",map("".$_->[0]."".$_->[1]."\n",@$val)) - if ref $val; - $r.="$val"; - $r.="\n"; -} - - print ''."\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; -} - -sub project_arr_to_hash (@) -{ -my(@arr)=@_; - - return ( - @arr, - "keys_array"=>[ My::Web::arr_keys(@arr) ], - ); -} - -sub title ($$) -{ -my($class,$hashref)=@_; - - return $hashref->{"name"}.": ".$hashref->{"summary"}, -} - -# $args{"ListItem"}=\%...; -sub init_project ($%) -{ -my($class,%args)=@_; - - my $ListItem={ project_arr_to_hash(@{$args{"ListItem"}}) }; - my $W=$class->init( - "title"=>$class->title($ListItem), - map(("rel_$_"=>top_dir('/project/Rel.pl?rel='.$_.'&project='.($args{"__PACKAGE__"}=~/^.*::([^:]+)::[^:]+$/)[0])), - qw(prev next)), - "rel_up"=>top_dir('/project/'), -# "rel_start"=>top_dir(), # TODO:homepage - %args, - # FIXME: "head_css" no longer exists in My::Web branch "apache2" - "head_css"=>($args{"head_css"} || "")." -table.print_project td { vertical-align: top; } -", - "WebConfig::heading_novskip"=>1, - ); - $class->heading(); - print $class->platforms($ListItem->{"platform"}); - $class->print_project({ %$ListItem },%args); - return $W; -} - -sub one_item_list_read($$) -{ -my($class,$name)=@_; - - Wrequire "project::${name}::ListItem"; - my $item=eval('\@project::'.$name.'::ListItem::ListItem'); - do { warn "Broken project/$name/ListItem.pm"; next; } if !defined $item; - return @$item; -} - -sub item_hash_read () -{ -# FIXME: $class - my %dirs; - for my $ENTRIES (ENTRIES(),ENTRIES_LOG()) { - local *E; - next if !open E,$ENTRIES; - while () { - chomp; - do { $dirs{$1}=1; next; } if m#^(?:A )?D/([^/]*)/#; - next if m#^/([^/]*)/# ; - next if /^D$/; - warn "File $ENTRIES contains invalid line \"$_\": $!"; - } - close E; - } - - my %item; - for my $dir (keys(%dirs)) { - Wrequire "project::${dir}::ListItem"; - my $item=eval('\@project::'.$dir.'::ListItem::ListItem'); - do { warn "Broken project/$dir/ListItem.pm"; next; } if !defined $item; - $item{$dir}={ My::Project::project_arr_to_hash(My::Project->one_item_list_read($dir)) }; - } - return %item; -} - -our @platforms=( - "unixuser"=>"UNIX", - "unixdevel"=>"UNIX-devel", - "web"=>"Web", - "amiga"=>"Amiga", - "w32"=>"MS-Windows", - "dos"=>"MS-DOS", - "patch"=>"Patches", - ); - -sub views ($$) -{ -my($class,$view_selected)=@_; - - my $view=sub ($$) - { - my($current,$href,$content)=@_; - - return a_href($href,$content) if $current ne $view_selected; - return "".$content." (current)"; - }; - - return <<"HERE"; -

Project List of @{[ a_href 'http://www.jankratochvil.net/','Jan Kratochvil' ]}

- -
    -
  • @{[ &{$view}('Detailed' ,'/project/','Detailed project listing per platform') ]}
    • -
  • @{[ &{$view}('BriefPlatform','/project/List.html.pl?platform=platform', - 'Brief project listing per platform') ]}
    • -
  • @{[ &{$view}('BriefUnified' ,'/project/List.html.pl', - 'Unified brief project listing') ]}
    • -
-@{[ vskip "1ex" ]} -HERE -} - -sub platforms ($;$%) -{ -my($class,$platform_selected,%args)=@_; - - my $r=""; - $r.=''."\n"; - $r.=''; - $r.=''."\n"; - $r.='
'; - $r.=''."\n"; - $r.=''."\n"; - $r.=''."\n"; - $r.=''."\n"; - $r.='
'."\n"; - $r.='Projects'; - $r.='
'; - $r.='		'; - $r.=''."\n"; - $r.=''."\n"; - my @platforms=@platforms; - while (@platforms) { - my $platform_sym =shift @platforms; - my $platform_name=shift @platforms; - my $chosen=($platform_selected && $platform_selected eq $platform_sym); - $r.='\n"; - } - $r.=''."\n"; - $r.='
'; - $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 */"')); - $r.="
'."\n"; - $r.='
'."\n"; - if (!$args{"novskip"}) { - $r.="
\n"; - $r.=My::Web::vskip "6ex"; - } - $r; -} - -sub section ($$) -{ -my($class,$name)=@_; - - my %item=( $class->one_item_list_read($name) ); - my $title=$class->title(\%item); - my $r=""; - - print $class->platforms($item{"platform"},"novskip"=>1); - - $r.=''."\n"; - $r.=''."\n"; - $r.='
'; - $r.=''."\n"; - $r.=''."\n"; - $r.='
'."\n"; - $r.=a_href "/project/$name/",$title; - $r.='
'."\n"; - $r.='
'."\n"; - $r.=vskip "1ex"; - $r; -} - -1;