#
# 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
);
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 CGI;
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;
#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.
cluck "W not empty:\n".Dumper($W) 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();
# See: &escapeHTML
do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset();
CGI::charset("utf-8");
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(); },
}),
);
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"};
}
$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"}) {
$W->{"head"}.=''."\n";
}
do { _args_check(%$_) if $_; } for ($W->{"args_check"});
$W->{"_init_done"}=1;
return $W;
}
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
{
cluck "exit_hook_start() twice?" 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;
cluck "INTERNAL: exit_orig uninitialized" 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 ...
# CGI requires valid "r": check it beforehand here.
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
}
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/;
}
}
}
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;
$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 "
\n";
}
packages_used_comments();
do { Wprint $_ if $_; } for $W->{"footing"};
Wprint "