#
# 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 lib qw(/home/short/lib/perl5/site_perl/5.6.0/i386-linux /home/short/lib/perl5/site_perl/5.6.0 /home/short/lib/perl5/site_perl/i386-linux /home/short/lib/perl5/site_perl /home/short/lib/perl5/5.6.0/i386-linux /home/short/lib/perl5/5.6.0 /home/short/lib/perl5/i386-linux /home/short/lib/perl5);
use Exporter;
our @EXPORT=qw(&require &a_href &a_href_cz &vskip &img $W);
our @ISA=qw(Exporter);
use 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)=@_;
$W={ %WebConfig,%args }; # override %WebConfig settings
$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 ("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"}.='{"r"}->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"});
$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() };
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 require ($)
{
my($file)=@_;
$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 fatal (;$);
sub args_check (%)
{
my(%tmpl)=@_;
while (my($name,$regex)=each(%tmpl)) {
my $name_html="Parametr ".CGI::escapeHTML($name)."";
my $val=$W->{"args"}{$name};
fatal "$name_html ".CGI::escapeHTML($val).""
." does not match required regex ".CGI::escapeHTML($regex).""
if defined $val && $val!~/$regex/;
fatal "$name_html is required"
if !defined $val;
}
}
sub vskip (;$)
{
my($height)=@_;
return '
'."\n";
}
sub fatal (;$)
{
my($msg)=@_;
$msg="UNKNOWN" if !$msg;
# heading(false/*title*/,false/*indexme*/); # notitle is always safe, don't index the error message
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"};
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 $W->{"top_dir"}."/$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__,
"WebConfig",
@{$W->{"packages_used"}{$Apache::Registry::curstash}},
)));
print "
\n";
}
print "