X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=0cf0d3c86a82bf96c78feede5c3c74e853eca885;hb=d352d10efbc9a65e73c0dbf60753558b1010dc63;hp=8449555673438cd4846afc4390562f08a121cdc8;hpb=0ba32bf6081668fdec9c925fe23f5a4a6d6ec8cb;p=MyWeb.git
diff --git a/Web.pm b/Web.pm
index 8449555..0cf0d3c 100644
--- a/Web.pm
+++ b/Web.pm
@@ -1,8 +1,6 @@
-#! /usr/bin/perl
-#
# $Id$
# Common functions for HTML/XHTML output generation
-# Copyright (C) 2003 Jan Kratochvil You can report this problem's details to"
- ." admin of this website.".$ListItem->{"name"}."
\n";
- print $ListItem->{"description"};
- print "
\n";
- my @table=(
- {"key"=>qr(^download\b.*),"text"=>sub ($) {
- $_[0]=~s/^download//;
- $_[0]=~s/^-/ /;
- return "Download".$_[0];
- },
- "format"=>sub ($) {
- my $r;
- if ($_[0]=~m#^[a-z]+://#) {
- $r="".CGI::escapeHTML($_[0])."";
- }
- else {
- $r="".CGI::escapeHTML(basename($_[0]))."";
- my $size=(stat $_[0])[7];
- die "Cannot stat \"".$_[0]."\": $!" if !defined $size;
- if ($size>=1024*1024) { $size=int($size/(1024*1024))." MB"; }
- elsif ($size>=1024 ) { $size=int($size/(1024 ))." KB"; }
- else { $size=int($size )." B"; }
- $r.=" ($size)";
- }
- return $r;
- }},
- {"key"=>qr(^link\b.*),"text"=>sub ($) {
- $_[0]=~s/^link-//;
- return $_[0];
- },
- "format"=>sub ($) {
- return "".CGI::escapeHTML($_[0])."";
- }},
- {"key"=>"summary","text"=>"Summary"},
- {"key"=>"ownership","text"=>"Ownership"},
- {"key"=>"license","text"=>"License","format"=>sub ($) {
- my %known=(
- "PD"=>"Public Domain",
- "GPL"=>"GNU General Public License",
- "LGPL"=>"GNU Lesser General Public License",
- );
- return $known{$_[0]};
- }},
- {"key"=>"maintenance","text"=>"Currently maintained?","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.",
- );
- return $known{$_[0]};
- }},
- {"key"=>"reason","text"=>"Reason"},
- {"key"=>"sponsorship","text"=>"Sponsoring Company"},
- {"key"=>"language","text"=>"Programming language","format"=>sub ($) {
- return "".CGI::escapeHTML($_[0]).""
- if $_[0]=~/^Java\b/;
- return "".CGI::escapeHTML($_[0]).""
- if $_[0]=~/^PHP\b/;
- return undef();
- }},
- );
- print ''."\n";
-sub tableit_func
+ do { _args_check(%$_) if $_; } for ($W->{"args_check"});
+
+ return bless $W,$class;
+}
+
+# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself.
+# Do not: Wprint $W->{"heading"},"undef"=>1;
+# as we would need to undef() it to turn it off and it would get defaulted in such case.
+# Do not: exists $W->{"heading"}
+# as we use a lot of 'for $W->{"heading"}' which instantiates it with the value: undef()
+sub Wprint($%)
{
-my($tableit,$val,$key,$ListItem)=@_;
+my($text,%args)=@_;
+
+ cluck "undef Wprint" if !defined $text && !$args{"undef"};
+ delete $args{"undef"};
+ cluck join(" ","Invalid arguments:",keys(%args)) if keys(%args);
+ $W->{"r"}->puts($text) if defined $text;
+}
- print "
\n";
- print " \n";
- delete $ListItem->{$key};
+ return $W->{"unparsed_uri"};
}
- 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 (keys(%$ListItem)) {
- my $keyregex=$tableit->{"key"};
- next if $key!~/$keyregex/;
- tableit_func($tableit,$ListItem->{$key},$key,$ListItem);
- }
+sub in_to_uri_abs($)
+{
+my($in)=@_;
+
+ # Otherwise we may have been already processed and thus legally relativized.
+ # FIXME data: Currently disabled, all the data are too violating such rule.
+ if (0 && !ref $in) {
+ my $uri_check=URI->new($in);
+ $uri_check->scheme() || $in=~m{^\Q./\E} || $in=~m{^/}
+ or cluck "Use './' or '/' prefix for all the local references: $in";
+ }
+ my $uri=URI->new_abs($in,unparsed_uri());
+ $uri=$uri->canonical();
+ return $uri;
+}
+
+# $args{"uri_as_in"}=1 to permit passing URI objects as: $in
+# $args{"abs"}=1;
+sub path_web($%)
+{
+my($in,%args)=@_;
+
+ cluck if !$args{"uri_as_in"} && ref $in;
+ my $uri=in_to_uri_abs($in);
+ if (uri_is_local($uri)) {
+ # Prefer the $uri values over "args_persistent" values.
+ $uri->query_form_hash({
+ map({
+ my $key=$_;
+ my $val=$W->{"args"}{$key};
+ (!defined $val ? () : ($key=>$val));
+ } keys(%{$W->{"args_persistent"}})),
+ %{$uri->query_form_hash()},
+ });
+ }
+ return $uri->abs(unparsed_uri()) if $W->{"args"}{"Wabs"} || $args{"abs"};
+ return $uri->rel(unparsed_uri());
+}
+
+# $args{"uri_as_in"}=1 to permit passing URI objects as: $in
+sub path_abs_disk($%)
+{
+my($in,%args)=@_;
+
+ cluck if !$args{"uri_as_in"} && ref $in;
+ my $uri=in_to_uri_abs($in);
+ cluck if !uri_is_local($uri);
+ my $path=$uri->path();
+ cluck "URI compatibility: ->path() not w/leading slash of URI \"$uri\"; path: $path" if $path!~m{^/};
+ return dir_top_abs_disk().$path;
+}
+
+sub fatal (;$);
+
+sub _args_check (%)
+{
+my(%tmpl)=@_;
+
+ while (my($name,$regex)=each(%tmpl)) {
+ my $name_html="Parameter ".escapeHTML($name)."";
+ $W->{"args"}{$name}="" if !defined $W->{"args"}{$name};
+ $W->{"args"}{$name}=[ $W->{"args"}{$name} ] if !ref $W->{"args"}{$name} && ref $regex;
+ fatal "$name_html passed as multivar although singlevar expected"
+ if ref $W->{"args"}{$name} && !ref $regex;
+ $regex=$regex->[0] if ref $regex;
+ for my $val (!ref $W->{"args"}{$name} ? $W->{"args"}{$name} : @{$W->{"args"}{$name}}) {
+ $val="" if !defined $val;
+ fatal "$name_html ".escapeHTML($val).""
+ ." does not match the required regex ".escapeHTML($regex)." "
+ if $regex ne "" && $val!~/$regex/;
}
}
- print "";
- if (!ref $tableit->{"text"}) {
- print $tableit->{"text"};
+sub escapeHTML($)
+{
+my($text)=@_;
+
+ # Prevent &CGI::escapeHTML breaking utf-8 strings like: \xC4\x9B eq \x{11B}
+ # Prevent case if we run under mod_perl but still just initializing:
+ request_check() if $ENV{"MOD_PERL"};
+ # Generally we are initialized from &init but we may be used without it without mod_perl
+ # and in such case check the change on all non-first invocations.
+ our $init;
+ if (!$ENV{"MOD_PERL"} && $init++) {
+ do { cluck "charset==$_" if $_ ne "utf-8"; } for CGI::charset();
}
- else {
- my $textfunc=$tableit->{"text"};
- my $key=$key;
- print &$textfunc($key);
+ CGI::charset("utf-8");
+
+ return CGI::escapeHTML($text);
+}
+
+# local *FH;
+# tie *FH,ref($W),$W;
+sub TIEHANDLE($)
+{
+my($class,$W)=@_;
+
+ my $self={};
+ $self->{"W"}=$W or confess "Missing W";
+ return bless $self,$class;
+}
+
+sub WRITE
+{
+my($self,$scalar,$length,$offset)=@_;
+
+ Wprint substr($scalar,0,$length);
+}
+
+# /home/user/www/webdir
+sub dir_top_abs_disk()
+{
+ our $dir_top_abs_disk;
+ if (!$dir_top_abs_disk) {
+ my $selfpkg_relpath=__PACKAGE__;
+ $selfpkg_relpath=~s{::}{/}g;
+ $selfpkg_relpath.=".pm";
+ my $selfpkg_abspath=$INC{$selfpkg_relpath} or do {
+ cluck "Unable to find self package $selfpkg_relpath";
+ return;
+ };
+ $selfpkg_abspath=~s{/*\Q$selfpkg_relpath\E$}{} or do {
+ cluck "Unable to strip myself \"$selfpkg_relpath\" from the abspath: $selfpkg_abspath";
+ return;
+ };
+ cluck "INC{myself} is relative?: $selfpkg_abspath" if $selfpkg_abspath!~m{^/};
+ $dir_top_abs_disk=$selfpkg_abspath;
}
- print ": ";
- if ($tableit->{"format"}) {
- my $format=$tableit->{"format"};
- my $valn=&$format($val);
- $val=$valn if defined $valn;
+ return $dir_top_abs_disk;
+}
+
+sub unparsed_uri()
+{
+ request_check();
+ if (!$W->{"unparsed_uri"}) {
+ # Do not: $W->{"r"}
+ # as we may be called before &init from: &My::Project::init
+ my $r=Apache2::RequestUtil->request();
+ cluck "Calling ".'&unparsed_uri'." from a static code, going to fail" if !$r;
+ my $uri_string=$r->unparsed_uri() or cluck "Valid 'r' missing unparsed_uri()?";
+ my $uri=URI->new_abs($uri_string,"http://".$W->{"web_hostname"}."/");
+ $W->{"unparsed_uri"}=$uri;
}
- print "$val
FATAL ERROR: $msg!
\n"
+ cluck "FATAL: $msg";
+
+ # Do not send it unconditionally.
+ # The intial duplicated '{"heading_done"}=0 if $W->{"header_only"};
+ # Do not send it unconditionally.
+ # Prevents warn: Headers already sent
+ if (!$W->{"heading_done"}) {
+ $W->{"indexme"}=0; # For the case no heading was sent yet.
+ $W->{"header_only"}=0; # assurance for &heading
+ My::Web->heading();
+ }
+ Wprint "\n".vskip("3ex")."FATAL ERROR: $msg!
\n"
."
\n" if $delimit; - print "
$cvs_id_html
\n"; + my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; + + if ($W->{"footer_ids"}) { + Wprint '';
+ Wprint join("
\n",map({ my $package=$_;
+ my $cvs_id=(eval('$'.$package."::CVS_ID")
+# || $package # debug
+ );
+ if (!$cvs_id) {
+ ();
+ }
+ else {
+ $cvs_id='$'.$cvs_id.'$'; # Eaten by 'q' operator.
+ my @cvs_id_split=split / +/,$cvs_id;
+ if (@cvs_id_split==8) {
+ my $file=$package;
+ $file=~s#::#/#g;
+ my $ext;
+ my @tried;
+ for (qw(.pm)) {
+ $ext=$_;
+ my $path_abs_disk=path_abs_disk("/$file$ext");
+ push @tried,$path_abs_disk;
+ last if -r $path_abs_disk;
+ cluck "Class file $file not found; tried: ".join(" ",@tried) if !$ext;
+ }
+ $file.=$ext;
+ $cvs_id_split[2]=""
+ .a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $W->{"viewcvs"}))[0]."$file?rev=".$cvs_id_split[2],
+ $cvs_id_split[2]);
+ $cvs_id_split[1]=a_href($W->{"viewcvs"}.$file,
+ ($package!~/^Apache2::/ ? $package : $cvs_id_split[1]));
+ $cvs_id_split[5]=&{$W->{"cvs_id_author_sub"}}($cvs_id_split[5]);
+ }
+ join " ",@cvs_id_split;
+ }
+ } @$packages_used));
+ Wprint "