X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=6b76695d16763b4e9e7cbe50dfbd052c4ad4283e;hb=ee36f55cab44a05ddb218efafc9e553070baba8e;hp=013274afe560a059234981aae26b7a934f792177;hpb=b1db84dfd24064aa8bdf9edc49b417f9f2ffb2b2;p=MyWeb.git
diff --git a/Web.pm b/Web.pm
index 013274a..6b76695 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";
+ print STDERR "$class->init ".Apache2::RequestUtil->request()->unparsed_uri()."\n";
-sub tableit_func
-{
-my($tableit,$val,$key,$ListItem)=@_;
+ # We need to track package dependencies, so we need to call it from &init.
+ # We cannot do it in BEGIN { } block
+ # as it would not be tracked for each of the toplevel users later.
+ Wuse 'WebConfig';
+ Wrequire 'My::Hash';
+
+ $W=My::Hash->new({
+ "__PACKAGE__"=>scalar(caller()),
+ %WebConfig,
+ %args, # override %WebConfig settings
+ },"My::Hash::Sub","My::Hash::Push");
+
+ # {"__PACKAGE__"} is mandatory for mod_perl-2.0;
+ # $Apache2::Registry::curstash is no longer supported.
+ do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";
+
+ # See: &escapeHTML
+ do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset();
+ CGI::charset("utf-8");
- print "
\n";
- print " \n";
- delete $ListItem->{$key};
+
+ do { _args_check(%$_) if $_; } for ($W->{"args_check"});
+
+ return bless $W,$class;
}
- 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);
- }
+# Be aware other parts of code (non-My::Web) will NOT use this function!
+# 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($text,%args)=@_;
+
+ cluck "undef Wprint" if !defined $text && !$args{"undef"};
+ delete $args{"undef"};
+ cluck join(" ","Invalid arguments:",keys(%args)) if keys(%args);
+ return if !defined $text;
+ cluck "utf-8 untested" if Encode::is_utf8($text);
+ $W->{"r"}->puts($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();
+ }
+ CGI::charset("utf-8");
+
+ return CGI::escapeHTML($text);
+}
+
+# /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;
+ }
+ 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;
+ }
+ return $W->{"unparsed_uri"};
+}
+
+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());
+}
+
+sub path_abs_disk_register($)
+{
+my($path_abs_disk)=@_;
+
+ $W->{"path_abs_disk_register"}{$path_abs_disk}=1;
+}
+
+# $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{^/};
+ my $r=dir_top_abs_disk().$path;
+ path_abs_disk_register $r if !defined $args{"register"} || $args{"register"};
+ return $r;
+}
+
+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"};
+ do { $W->{$_}=0 if !defined $W->{$_}; } for "detect_ent";
+ do { $W->{$_}=0 if !defined $W->{$_}; } for "detect_js";
+ do { $W->{$_}=1 if !defined $W->{$_}; } for "have_css"; # AFAIK it does not hurt anyone.
+ do { $W->{$_}=0 if !defined $W->{$_}; } for "css_inherit";
+ do { $W->{$_}=1 if !defined $W->{$_}; } for "footer";
+ do { $W->{$_}=1 if !defined $W->{$_}; } for "footer_delimit";
+ do { $W->{$_}=1 if !defined $W->{$_}; } for "footer_ids";
+ do { $W->{$_}=1 if !defined $W->{$_}; } for "indexme";
+ do { $W->{$_}="" if !defined $W->{$_}; } for "head";
+ do { $W->{$_}="" if !defined $W->{$_}; } for "body_attr";
+ do { $W->{$_}="en-US" if !defined $W->{$_}; } for "language";
+
+ my $footer_any=0;
+ for (qw(footer_ids)) {
+ $W->{$_}=0 if !$W->{"footer"};
+ $footer_any=1 if $W->{$_};
+ }
+ $W->{"footer"}=0 if !$footer_any;
+ $W->{"footer_delimit"}=0 if !$W->{"footer"};
+
+ $W->{"r"}=Apache2::RequestUtil->request();
+
+ $W->{"r"}->push_handlers("PerlCleanupHandler"=>\&cleanup);
+
+ $W->{"web_hostname"}||=$W->{"r"}->hostname();
+
+ tie *STDOUT,$W->{"r"};
+ select *STDOUT;
+ $|=1;
+
+ $W->{"QUERY_STRING"}=$W->{"r"}->args() || "";
+ if ($W->{"detect_ent"}) {
+ if ($W->{"QUERY_STRING"}=~/[&]amp;have_ent/)
+ { $W->{"have_ent"}=0; }
+ elsif ($W->{"QUERY_STRING"}=~ /[&]have_ent/)
+ { $W->{"have_ent"}=1; }
+ else
+ { delete $W->{"have_ent"}; }
+ if (!defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") {
+ $W->{"head"}.='{"web_hostname"}."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0]
+ ."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect')
+ .'" />'."\n";
+ }
+ }
+ $W->{"QUERY_STRING"}=~s/([&])amp;/$1/g;
+ $W->{"r"}->args($W->{"QUERY_STRING"});
+ # Workaround: &CGI::Vars behaves weird if strings passed both as POST data and in: $QUERY_STRING
+ do { $W->{"r"}->args(""); delete $ENV{"QUERY_STRING"}; } if $W->{"r"}->method() eq "POST";
+ # Do not: $W->{"r"}->args()
+ # as it parses only QUERY_STRING (not POST data).
+ $W->{"args_orig_array"}=[ CGI->new($W->{"r"})->Vars() ];
+ $W->{"args"}={ @{$W->{"args_orig_array"}} };
+ for my $name (keys(%{$W->{"args"}})) {
+ my @vals=split /\x00/,$W->{"args"}{$name};
+ next if @vals<=1;
+ $W->{"args"}{$name}=[@vals];
+ }
+
+ $W->{"headers_in"}=$W->{"r"}->headers_in();
+ Wrequire 'My::Hash::Merge';
+ $W->{"headers_in"}=My::Hash::Merge->new(
+ $W->{"headers_in"},
+ My::Hash::Sub->new({
+ "_remote_ip"=>sub { return $W->{"r"}->connection()->remote_ip(); },
+ }),
+ );
+ $W->{"headers_in"}=My::Hash::Readonly->new($W->{"headers_in"});
+
+ if ($W->{"r"}->method() eq "GET" || $W->{"r"}->method() eq "HEAD") {
+ for (\$W->{"http_safe"}) {
+ # Extend the current ETag system instead if you would need it:
+ cluck "Explicitely NOT HTTP-Safe for method \"".$W->{"r"}->method()."\"?!?"
+ if defined($$_) && !$$_;
+ $$_=1 if !defined $$_;
+ }
}
else {
- my $textfunc=$tableit->{"text"};
- my $key=$key;
- print &$textfunc($key);
+ for (\$W->{"http_safe"}) {
+ cluck "Undefined HTTP-Safe-ty for method \"".$W->{"r"}->method()."\"!"
+ if !defined($$_);
+ $$_=0 if !defined $$_;
+ }
+ }
+ if ($W->{"http_safe"}) {
+ Wrequire 'My::Hash::RecordKeys';
+ $W->{"headers_in_RecordKeys"}=My::Hash::RecordKeys->new($W->{"headers_in"});
+ $W->{"headers_in"}=$W->{"headers_in_RecordKeys"};
}
- print ": ";
- if ($tableit->{"format"}) {
- my $format=$tableit->{"format"};
- my $valn=&$format($val);
- $val=$valn if defined $valn;
+
+ $W->{"browser"}=HTTP::BrowserDetect->new($W->{"headers_in"}{"User-Agent"});
+
+ if (!defined $W->{"have_style"}) {
+ $W->{"have_style"}=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0);
+ }
+
+ $W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0);
+ if ($W->{"detect_js"} && !$W->{"have_js"}) {
+ $W->{"head"}.=''."\n";
}
- print "$val
FATAL ERROR: $msg!
\n"
+ # 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"; - print "