#
# 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 &a_href &a_href_cz &vskip &img ¢erimg &rightimg $W &top_dir &top_dir_disk);
our @ISA=qw(Exporter);
BEGIN
{
sub Wrequire ($)
{
my($file)=@_;
# print STDERR "Wrequire $file\n";
$file=~s#/#::#g;
$file=~s/[.]pm$//;
my $class=$file;
$file=~s#::#/#g;
$file.=".pm";
my $aref=($W->{"packages_used"}{$Apache::Registry::curstash}||=[]);
push @$aref,$class
if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries.
CORE::require $file;
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;
}
}
BEGIN { Wuse 'WebConfig'; } # for %WebConfig
require CGI; # for &escapeHTML
require Image::Size; # for &imgsize
use File::Basename; # &basename
use Carp qw(cluck confess);
use URI::Escape;
require HTTP::BrowserDetect;
require HTTP::Negotiate;
require Geo::IP;
require CGI;
# Undo 'www/engine/httpd-restart' as it may use obsolete Perl for 'mod_perl'
delete $ENV{"PERLLIB"};
delete $ENV{"LD_LIBRARY_PATH"};
#our $W;
# $W->{"title"}
# $W->{"head"}
# $W->{"head_css"}
# $W->{"force_charset"}
# %{$W->{"packages_used"}
# $W->{"heading_done"}
# $W->{"footer_passed"}
# %{$W->{"headers"}}
# %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key
# @{$W->{"packages_used"}{$Apache::Registry::curstash}}}
# %{$W->{"args"}}
sub init ($%)
{
my($class,%args)=@_;
print STDERR "$class->init ".$ENV{"REQUEST_URI"}."\n";
my $packages_used_save=$W->{"packages_used"};
$W={ %WebConfig,%args }; # override %WebConfig settings
$W->{"packages_used"}=$packages_used_save;
$W->{"__PACKAGE__"}||="Apache::ROOT".$Apache::Registry::curstash;
$W->{"top_dir"}||=eval '$'.$W->{"__PACKAGE__"}.'::top_dir';
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->{$_}=1 if !defined $W->{$_}; } for ("heading");
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_mailme");
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 ("head_css");
my $footer_any=0;
for (qw(footer_mailme 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"}=Apache->request();
$W->{"QUERY_STRING"}=$W->{"r"}->args() || "";
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 ($W->{"detect_ent"} && !defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") {
$W->{"head"}.='{"web_hostname_sub"}}()."/".($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"});
$ENV{"QUERY_STRING"}=$W->{"QUERY_STRING"};
# Do not: $W->{"r"}->args()
# as it parses only QUERY_STRING (not POST data).
$W->{"args"}={ CGI->new()->Vars() };
for (keys(%{$W->{"args"}})) {
my @vals=split /\x00/,$W->{"args"}{$_};
next if @vals<=1;
$W->{"args"}{$_}=[@vals];
}
do { $W->{$_}=$ENV{"HTTP_ACCEPT"} if !defined $W->{$_}; } for ("accept");
do { $W->{$_}=$ENV{"HTTP_USER_AGENT"} if !defined $W->{$_}; } for ("user_agent");
$W->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"});
if (!defined $W->{"have_style"}) {
$W->{"have_style"}=(!$W->{"browser"}->netscape() || $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"});
return $W;
}
sub top_dir_disk ()
{
do { return $_ if $_; } for ($W->{"top_dir"});
return $INC[0]; # fallback
}
sub top_dir (;$)
{
my($in)=@_;
if (my $uri=$ENV{"REQUEST_URI"}) {
$uri.="Index" if $uri=~m#/$#;
if (defined $in) {
my($inpath,$inquery)=split /[?]/,$in,2;
$inpath=~tr///cs;
$uri=~tr///cs;
for (;;) {
my($in1 ,$in2 )=($in =~m#^(/[^/]+)(/.*)$#);
my($uri1,$uri2)=($uri=~m#^(/[^/]+)(/.*)$#);
last if !defined $in1 || !defined $uri1 || $in1 ne $uri1;
$in=$in2;
$uri=$uri2;
}
}
$uri=~s#^/*##;
$uri=~s#[^/]+#..#g;
$uri=File::Basename::dirname($uri);
my $r=$uri.(defined $in ? $in : "");
# 1 while $r=~s#^[.]/##;
# $r="./$r" if $r=~m#^(?:?.*)$#; # empty pathname?
return $r;
}
return top_dir_disk().$in;
}
sub fatal (;$);
sub args_check (%)
{
my(%tmpl)=@_;
while (my($name,$regex)=each(%tmpl)) {
my $name_html="Parameter ".CGI::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 ".CGI::escapeHTML($val).""
." does not match the required regex ".CGI::escapeHTML($regex)." "
if $regex ne "" && $val!~/$regex/;
}
}
}
sub vskip (;$)
{
my($height)=@_;
return '
'."\n";
}
sub fatal (;$)
{
my($msg)=@_;
$msg="UNKNOWN" if !$msg;
$W->{"indexme"}=0; # For the case no heading was sent yet.
My::Web->heading();
print "\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";
footer();
}
sub footer (;$)
{
exit 1 if $W->{"footer_passed"}++; # deadlock prevention:
print vskip if $W->{"footer_delimit"};
if ($W->{"heading"}) {
do { &{$_}() if $_; } for ($W->{"footing_delimit"});
}
print "
\n" if $W->{"footer"};
if ($W->{"footer_mailme"}) {
print ''."\n";
}
if ($W->{"footer_ids"}) {
print '';
print 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;
for (qw(.html.pl .pl .pm),"") {
$ext=$_;
last if -r top_dir_disk()."/$file$ext";
cluck "Class file $file not found" 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!~/^Apache::/ ? $package : $cvs_id_split[1]));
$cvs_id_split[5]=&{$W->{"cvs_id_author"}}($cvs_id_split[5]);
}
join " ",@cvs_id_split;
}
} (
$W->{"__PACKAGE__"},
__PACKAGE__,
@{$W->{"packages_used"}{$Apache::Registry::curstash}},
)));
print "
\n";
}
for my $package (
$W->{"__PACKAGE__"},
__PACKAGE__,
@{$W->{"packages_used"}{$Apache::Registry::curstash}},
) {
my $cvs_id=(eval('$'.$package."::CVS_ID")
# || $package # debug
);
print ''."\n" if $cvs_id;
}
if ($W->{"heading"}) {
do { &{$_}() if $_; } for ($W->{"footing"});
}
print "