#
# 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_cz
&vskip
&img ¢erimg &rightimg
$W
&input_hidden_persistents
);
our @ISA=qw(Tie::Handle Exporter);
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 $W->{'packages_used%'}{$caller}{$target}++;
push @{$W->{'packages_used@'}{$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; # 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;
my $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);
use URI;
use URI::QueryParam;
use Cwd;
#our $W;
# $W->{"title"}
# $W->{"head"}
# $W->{"force_charset"}
# $W->{"heading_done"}
# $W->{"footer_passed"}
# %{$W->{"headers"}}
# %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key
# @{$W->{'packages_used@'}{callers...}}
# %{$W->{'packages_used%'}{callers...}}
# %{$W->{"args"}}
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::Sub';
my $packages_used_array_save=$W->{'packages_used@'};
my $packages_used_hash_save =$W->{'packages_used%'};
$W={};
tie %$W,"My::Hash::Sub";
%$W=(%WebConfig,%args); # override %WebConfig settings
$W->{'packages_used@'}=$packages_used_array_save;
$W->{'packages_used%'}=$packages_used_hash_save;
$W->{"__PACKAGE__"}||=caller();
# {"__PACKAGE__"} is mandatory for mod_perl-2.0;
# $Apache2::Registry::curstash is no longer supported.
do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__";
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_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();
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"}={ CGI->new($W->{"r"})->Vars() };
for my $name (keys(%{$W->{"args"}})) {
my @vals=split /\x00/,$W->{"args"}{$name};
next if @vals<=1;
$W->{"args"}{$name}=[@vals];
}
do { $W->{$_}=$W->{"r"}->headers_in()->{"Accept"} if !defined $W->{$_}; } for ("accept");
do { $W->{$_}=$W->{"r"}->headers_in()->{"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() && $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"});
$ENV{"HOSTNAME"}||=$W->{"web_hostname"};
return bless $W,$class;
}
# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself.
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);
$W->{"r"}->puts($text) if defined $text;
}
sub escapeHTML($)
{
my($text)=@_;
# 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 dynamic URL generator from a static code" if !eval { Apache2::RequestUtil->request(); };
return CGI::escapeHTML($text);
}
# local *FH;
# tie *FH,ref($W),$W;
sub TIEHANDLE($)
{
my($class,$W)=@_;
my $self={};
$self->{"W"}=$W or confess "Missing W";
return bless $self,$class;
}
sub WRITE
{
my($self,$scalar,$length,$offset)=@_;
Wprint substr($scalar,0,$length);
}
# /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()
{
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"}||$WebConfig{"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
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());
}
# $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{^/};
return dir_top_abs_disk().$path;
}
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";
footer();
}
sub footer (;$)
{
exit 1 if $W->{"footer_passed"}++; # deadlock prevention:
Wprint vskip if $W->{"footer_delimit"};
Wprint $W->{"footing_delimit"},"undef"=>1;
Wprint "
\n" if $W->{"footer"};
my $packages_used=$W->{'packages_used@'}{$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";
}
for my $package (@$packages_used) {
my $cvs_id=(eval('$'.$package."::CVS_ID")
# || $package # debug
);
Wprint ''."\n" if $cvs_id;
}
Wprint $W->{"footing"},"undef"=>1;
Wprint "