#
# 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::Web;
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 Exporter;
sub Wrequire($);
sub Wuse($@);
our $W;
our @EXPORT=qw(
&Wrequire &Wuse
&path_web &path_abs_disk
&uri_escaped
&a_href &a_href_cc
&vskip
&img ¢erimg &rightimg
$W
&input_hidden_persistents
&escapeHTML
&form_method
);
our @ISA=qw(Tie::Handle Exporter);
my %packages_used_hash; # $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
my %packages_used_array;
BEGIN
{
use Carp qw(cluck confess);
$W->{"__My::Web_init"}=1;
sub Wrequire ($)
{
my($file)=@_;
# print STDERR "Wrequire $file\n";
$file=~s#/#::#g;
$file=~s/[.]pm$//;
my $class=$file;
$file=~s#::#/#g;
$file.=".pm";
my %callers;
for (my $depth=0;defined caller($depth);$depth++) {
$callers{caller($depth)}=1;
}
my $selfpkg=__PACKAGE__;
$callers{$selfpkg}=1;
for my $target ($class,__PACKAGE__) {
for my $caller (keys(%callers)) {
next if $caller eq $target;
next if $packages_used_hash{$caller}{$target}++;
cluck "Appending to the '_done' package list: caller=$caller,target=$target"
if $packages_used_hash{$caller}{"_done"};
push @{$packages_used_array{$caller}},$target;
}
}
eval { CORE::require "$file"; } or confess $@;
1; # Otherwise 'require' would already file above.
}
sub Wuse ($@)
{
my($file,@list)=@_;
# print STDERR "Wuse $file\n";
Wrequire $file;
local $Exporter::ExportLevel=$Exporter::ExportLevel+1;
$file->import(@list);
1;
}
sub import
{
my($class,@rest)=@_;
local $Exporter::ExportLevel=$Exporter::ExportLevel+1;
Wrequire("$class");
return $class->SUPER::import(@rest);
}
}
use WebConfig; # see also below: Wuse 'WebConfig';
require Image::Size; # for &imgsize
use File::Basename; # &basename
use Carp qw(cluck confess);
use URI::Escape;
require HTTP::BrowserDetect;
require HTTP::Negotiate;
our $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; }
# Do not: use ModPerl::Util qw(exit);
# to prevent in mod_perl2: "exit" is not exported by the ModPerl::Util module
# I do not know why.
use POSIX qw(strftime);
use Tie::Handle;
use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK HTTP_OK);
use URI;
use URI::QueryParam;
use Cwd;
require HTTP::Date;
require Storable;
require Digest::MD5;
require Data::Compare;
use Data::Dumper;
require Encode;
use Apache2::Filter;
use Apache2::Connection;
require MIME::Base64;
use Apache2::ServerUtil;
require MIME::Types;
require MIME::Parser;
#our $W;
sub init ($%)
{
my($class,%args)=@_;
print STDERR "$class->init ".Apache2::RequestUtil->request()->unparsed_uri()."\n";
# 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={} can get somehow created very easily.
# Do not: cluck "W not empty:\n".Dumper($W) if keys(%$W);
# to prevent (of $W->{"headers_in"}): TODO: Enumeration may not be expected.
cluck "W not empty; __PACKAGE__ was: ".$W->{"__PACKAGE__"} if keys(%$W);
$W=My::Hash->new({},"My::Hash::Sub","My::Hash::Push");
bless $W,$class;
%$W=(
"__PACKAGE__"=>scalar(caller()),
%WebConfig,
%args, # override %WebConfig settings
);
# {"__PACKAGE__"} is mandatory for mod_perl-2.0;
# $Apache2::Registry::curstash is no longer supported.
do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";
exit_hook_start();
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->{"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 {
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"};
}
{
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";
}
do { _args_check(%$_) if $_; } for ($W->{"args_check"});
$W->{"_init_done"}=1;
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 {
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;
}
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";
}
sub fatal (;$)
{
my($msg)=@_;
$msg="UNKNOWN" if !$msg;
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"
."You can report this problem's details to"
." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".
\n";
exit;
}
sub footer_packages_used_comments()
{
my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}};
for my $package (@$packages_used) {
my $cvs_id=(eval('$'.$package."::CVS_ID")
# || $package # debug
);
Wprint ''."\n" if $cvs_id;
}
}
sub footer()
{
cluck 'Explicit &footer call is deprecated, !_exit_dne' if !$W->{"_exit_done"};
exit if $W->{"footer_done"}++; # deadlock prevention:
&{$_}() for reverse @{$W->{"footer_sub_push"}};
if ($W->{"header_only"}) {
$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
exit;
}
Wprint vskip if $W->{"footer_delimit"};
&{$_}() for reverse @{$W->{"footing_delimit_sub_push"}};
Wprint "
\n" if $W->{"footer"};
# Never update the package list while we examine it!
$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1;
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;
my $viewcvs;
if ((my $file_cvs=$file)=~s{^My/}{}) {
$viewcvs=$W->{"viewcvs_My"}.$file_cvs;
}
else {
$viewcvs=$W->{"viewcvs"}.$file;
}
$cvs_id_split[2]=""
.a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $viewcvs))[0]."?rev=".$cvs_id_split[2],
$cvs_id_split[2]);
$cvs_id_split[1]=a_href($viewcvs,($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 "
\n";
}
footer_packages_used_comments();
do { Wprint $_ if $_; } for $W->{"footing"};
Wprint "