X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=2b08495976dfb7b21ff5564128b49b0a5eb586e0;hp=c0d8c3cb90d613218eb8377bfc72035f1982f605;hb=282b6c63537989cafb73b4f6dfb79a2d216f50f7;hpb=fc0f3f8832778053713624c592c8d02df4b046a9
diff --git a/Web.pm b/Web.pm
index c0d8c3c..2b08495 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. No serious bugs known. No new features planned.",
- "dead"=>"Project became dead code. Some updates may be needed. It is no longer used.",
- );
- return $known{$_[0]};
- }},
- {"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";
+ $W->{"r"}->push_handlers("PerlCleanupHandler"=>\&cleanup);
-sub tableit_func
-{
-my($tableit,$val,$key)=@_;
+ $W->{"web_hostname"}||=$W->{"r"}->hostname();
+
+ tie *STDOUT,$W->{"r"};
+ select *STDOUT;
+ $|=1;
- print "
\n";
+ 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.
+ # &query_form_hash comes from: URI::QueryParam
+ $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/;
+ }
+ }
+}
+
+sub vskip (;$)
+{
+my($height)=@_;
+
+ return ' \n";
-}
- for my $tableit (@table) {
- if (!ref $tableit->{"key"}) {
- tableit_func($tableit,$ListItem->{$tableit->{"key"}},$tableit->{"key"}) if $ListItem->{$tableit->{"key"}};
+ {
+ local $_=$W->{"r"}->args() || "";
+ if ($W->{"detect_ent"}) {
+ if (/[&]amp;have_ent/)
+ { $W->{"have_ent"}=0; }
+ elsif ( /[&]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]
+ ."?".($_ || "detect_ent_glue=1").'&have_ent=detect')
+ .'" />'."\n";
+ }
}
+ s/([&])amp;/$1/g;
+ $W->{"r"}->args($_);
+ }
+
+ $W->{"args"}=URI->new("?".$W->{"r"}->args())->query_form_hash();
+ $W->merge_post_args() if $W->{"r"}->method() eq "POST";
+ # Prepare '$args' first to (FIXME: Why?) prevent: Not a reference
+ my $args=$W->{"args"};
+ $W->{"args_orig"}=Storable::dclone($args);
+
+ $W->{"browser"}=sub {
+ # Lazy-evaluation, we may not need the "User-Agent" header at all.
+ return our $r||=HTTP::BrowserDetect->new($W->{"headers_in"}{"User-Agent"});
+ };
+
+ if (!defined $W->{"have_style"}) {
+ $W->{"have_style"}=sub {
+ # Lazy-evaluation, we may not need the "User-Agent" header at all.
+ return our $r||=(!$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"}) {
+ # Do not:
+ # as at least Lynx inhibits any further HTML output.
+ # Do not: text/javascript
+ # as it does not look as registered, at least according to: MIME::Types $VERSION 1.15
+ # "application/javascript" so far standardized till 2005-12-08 by:
+ # http://www.ietf.org/internet-drafts/draft-hoehrmann-script-types-03.txt
+ $W->{"head"}.=''."\n";
+ }
+
+ # Required by &_args_check below.
+ $W->{"_init_done"}=1;
+
+ do { _args_check(%$_) if $_; } for $W->{"args_check"};
+
+ return $W;
+}
+
+sub form_method($)
+{
+my($method)=@_;
+
+ return q{enctype="application/x-www-form-urlencoded" accept-charset="us-ascii utf-8"} if $method eq "post";
+ return q{accept-charset="us-ascii utf-8"} if $method eq "get";
+ cluck "Undefined method: $method";
+ return ""
+}
+
+sub merge_post_args($)
+{
+my($class)=@_;
+
+ my @post_args=$class->read_post_args();
+ while (@post_args) {
+ my $name=shift @post_args;
+ my $data=shift @post_args;
+ my $ref=\$W->{"args"}{$name};
+ if (!defined $$ref) { $$ref=$data; }
+ elsif (!ref $$ref) { $$ref=[$$ref,$data]; }
+ elsif ("ARRAY" eq ref $$ref) { push @$$ref,$data; }
else {
- for my $key (keys(%$ListItem)) {
- my $keyregex=$tableit->{"key"};
- next if $key!~/$keyregex/;
- tableit_func($tableit,$ListItem->{$key},$key);
+ cluck "Ignoring POST argument \"$name\", orig is weird:\n",Dumper($$ref);
+ }
+ }
+ return;
+}
+
+# Do not: use CGI;
+# as CGI parsing of POST vs. QUERY_STRING data, multiple-valued keys etc.
+# is too dense and causes weird problems, together with mod_perl etc.
+sub read_post_args($)
+{
+my($class)=@_;
+
+ local $_=$class->http_headers_in_for("Content-type")->content_type();
+ return $class->read_multipart_form_data() if $_ eq "multipart/form-data";
+ return $class->read_application_x_www_form_urlencoded() if $_ eq "application/x-www-form-urlencoded";
+ cluck "Unknown POST data body, ignored: $_";
+ return;
+}
+
+sub read_application_x_www_form_urlencoded($)
+{
+my($class)=@_;
+
+ my $body="";
+ for (;;) {
+ my $got=$W->{"r"}->read(my($buf),0x1000);
+ # Do not: cluck "Error reading POST data: $!" if !defined $got;
+ # as it should be done using: APR::Error exceptions
+ last if !$got;
+ $body.=$buf;
+ }
+ return URI->new("?".$body)->query_form();
+}
+
+sub read_multipart_form_data($)
+{
+my($class)=@_;
+
+ my $parser=MIME::Parser->new();
+ # FIXME: No unlink()s done!
+ $parser->output_under("/tmp");
+
+ local *R_FH;
+ tie *R_FH,$W->{"r"};
+ local *FH;
+ tie *FH,"My::Web::ReadMerged",
+ join("",map(($_.": ".$W->{"headers_in"}{$_}."\n"),qw(
+ Content-type
+ )))."\n",
+ \*R_FH;
+ my $body=$parser->parse(\*FH);
+ cluck "No multipart POST request body?" if !$body->is_multipart();
+
+ return map((
+ $_->head()->mime_attr("content-disposition.name")
+ =>
+ join("",@{$_->body()})
+ ),$body->parts());
+
+ # TODO: Globalize, make it IO::* compatible, split to the merging part + IO::Scalar.
+ package My::Web::ReadMerged;
+
+ require Tie::Handle;
+ require Exporter;
+ our @ISA=qw(Tie::Handle Exporter);
+ use Carp qw(cluck confess);
+
+ sub READLINE($)
+ {
+ my($self)=@_;
+
+ confess "Slurp not yet implemented" if !defined $/;
+ # Apache2::RequestIO does not support 'READLINE'!
+ for (;;) {
+ if (defined $self->{"data"} && $self->{"data"}=~s{^.*\Q$/\E}{}) {
+ $self->{"offset"}+=length $&;
+ return $&;
+ }
+ my $fh_orig=$self->{"fh_orig"};
+ if (!$fh_orig) {
+ my $r=$self->{"data"};
+ delete $self->{"data"};
+ $self->{"offset"}+=length $r if defined $r;
+ return $r;
}
+ my $got=read $fh_orig,my($buf),0x1000;
+ cluck "Error reading POST data: $!" if !defined $got;
+ delete $self->{"fh_orig"} if !$got;
+ cluck "INTERNAL: fh_orig should not exist here" if !defined $self->{"data"};
+ $self->{"data"}.=$buf;
}
+ }
+
+ sub TELL($)
+ {
+ my($self)=@_;
+
+ return $self->{"offset"};
+ }
+
+ sub TIEHANDLE($$$)
+ {
+ my($class,$data,$fh_orig)=@_;
+
+ my $self=bless {},$class;
+ $self->{"data"}=$data;
+ $self->{"offset"}=0;
+ $self->{"fh_orig"}=$fh_orig;
+ return $self;
+ }
+}
+
+sub cleanup($)
+{
+my($apache_request)=@_;
+
+ cluck "CORE::GLOBAL::exit hook not ran" if !$W->{"_exit_done"};
+ cluck "packages not finalized" if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"};
+ cache_finish();
+ # Sanity protection.
+ $W=undef();
+ exit_hook_stop();
+ return OK;
+}
+
+# PerlResponseHandler is RUN_FIRST and &ModPerl::Util::exit returns OK, so no (sane) go.
+# PerlLogHandler is already too late to be able to produce any output.
+my $exit_orig;
+sub exit_hook
+{
+ cluck "Missing ->init while in exit_hook()" if !$W->{"_init_done"};
+ # &footer will call us recursively!
+ footer() if !$W->{"_exit_done"}++;
+ return &{$exit_orig}(@_);
+}
+sub exit_hook_start
+{
+ do { cluck "exit_hook_start() twice?"; return; } if defined $exit_orig;
+ $exit_orig=\&CORE::GLOBAL::exit;
+ # Prevent: Subroutine CORE::GLOBAL::exit redefined
+ no warnings 'redefine';
+ *CORE::GLOBAL::exit=\&exit_hook;
+}
+sub exit_hook_stop
+{
+ do { cluck "exit_hook_stop() without exit_hook_start()?"; return; }
+ if \&exit_hook ne \&CORE::GLOBAL::exit;
+ do { cluck "INTERNAL: exit_orig uninitialized"; return; }
+ if !$exit_orig;
+ # Prevent: Subroutine CORE::GLOBAL::exit redefined
+ no warnings 'redefine';
+ *CORE::GLOBAL::exit=$exit_orig;
+ $exit_orig=undef();
+}
+
+# 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;
+ # Do not: cluck "utf-8 untested" if Encode::is_utf8($text);
+ # as it is valid here.
+ $W->{"r"}->puts($text);
+}
+
+sub request_check(;$)
+{
+my($self)=@_;
+
+ # Use &eval to prevent: Global $r object is not available. Set:\n\tPerlOptions +GlobalRequest\nin ...
+ confess "Calling sensitive dynamic code from a static code" if !eval { Apache2::RequestUtil->request(); };
+ # Do not: confess "Calling sensitive dynamic code without My::Web::init" if !$W->{"__PACKAGE__"};
+ # as it is valid at least while preparing arguments to call: &project::Lib::init
+}
+
+# Do not: use CGI;
+# as it is too much backward compatible regarding the charset encodings etc.
+# and the resulting code is too dense with no additional functionality for the recent content.
+sub escapeHTML($)
+{
+my($text)=@_;
+
+ local $_=$text;
+ s{&}{&}gso;
+ s{<}{<}gso;
+ s{>}{>}gso;
+ s{"}{"}gso;
+ return $_;
+}
+
+# /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 (!ref $tableit->{"text"}) {
- print $tableit->{"text"};
+ $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(); },
+ }),
+ );
+ Wrequire 'My::Hash::Readonly';
+ $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"}) {
+ # Do not: # Extend the current ETag system instead if you would need it:
+ # cluck "Explicitely NOT HTTP-Safe for method \"".$W->{"r"}->method()."\"?!?"
+ # if defined($$_) && !$$_;
+ # as sometimes it just does not make sense to cache it.
+ $$_=1 if !defined $$_;
+ }
}
else {
- my $textfunc=$tableit->{"text"};
- print &$textfunc($key);
+ for (\$W->{"http_safe"}) {
+ cluck "Undefined HTTP-Safe-ty for method \"".$W->{"r"}->method()."\"!"
+ if !defined($$_);
+ $$_=0 if !defined $$_;
+ }
}
- print ": ";
- if ($tableit->{"format"}) {
- my $format=$tableit->{"format"};
- my $valn=&$format($val);
- $val=$valn if defined $valn;
+ # Used only if: $W->{"http_safe"}
+ # but we would cause on different method(): Appending to the '_done' package list
+ Wrequire 'My::Hash::RecordKeys';
+ if ($W->{"http_safe"}) {
+ $W->{"headers_in_RecordKeys"}=My::Hash::RecordKeys->new($W->{"headers_in"});
+ $W->{"headers_in"}=$W->{"headers_in_RecordKeys"};
}
- 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
+ $W->{"content_type"}="text/html"; # Force HTML and avoid strictly checked XHTML.
+ My::Web->heading();
+ }
+ Wprint "\n".vskip("3ex")."FATAL ERROR: $msg!
\n"
."
\n" if $delimit; - print "
$cvs_id_html
\n"; - print "