X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=5709a6333498a4101c46395038fb0a53bb696303;hb=56dba1eea7f284b39551bbedeb2af00cebcfe813;hp=d349658932313e5db632218a7d7f94a14a6a3522;hpb=c7ef95c38cb7fea2fa7112560ffdb69b79b7ffda;p=MyWeb.git diff --git a/Web.pm b/Web.pm index d349658..5709a63 100644 --- a/Web.pm +++ b/Web.pm @@ -27,11 +27,13 @@ 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 @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img ¢erimg &rightimg $W &top_dir &top_dir_disk &Wprint); our @ISA=qw(Exporter); BEGIN { + $W->{"__My::Web_init"}=1; + sub Wrequire ($) { my($file)=@_; @@ -42,7 +44,9 @@ BEGIN my $class=$file; $file=~s#::#/#g; $file.=".pm"; - my $aref=($W->{"packages_used"}{$Apache::Registry::curstash}||=[]); + my $who=$W->{"__PACKAGE__"}; + $who||="__My::Web" if $W->{"__My::Web_init"}; + my $aref=($W->{"packages_used"}{$who}||=[]); push @$aref,$class if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. CORE::require $file; @@ -69,13 +73,8 @@ 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"}; +my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; } +use ModPerl::Util qw(exit); #our $W; @@ -83,25 +82,27 @@ delete $ENV{"LD_LIBRARY_PATH"}; # $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->{"packages_used"}{$W->{"__PACKAGE__"}}} + # @{$W->{"packages_used"}{"__My::Web"}} # %{$W->{"args"}} sub init ($%) { my($class,%args)=@_; - print STDERR "$class->init ".$ENV{"REQUEST_URI"}."\n"; + print STDERR "$class->init ".Apache->request()->unparsed_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; + # {"__PACKAGE__"} is mandatory for mod_perl-2.0; + # $Apache::Registry::curstash is no longer supported. + do { cluck "No $_" if !$W->{$_}; } for "__PACKAGE__"; $W->{"top_dir"}||=eval '$'.$W->{"__PACKAGE__"}.'::top_dir'; @@ -142,18 +143,17 @@ my($class,%args)=@_; } $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() }; + $W->{"args"}={ CGI->new($W->{"r"})->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"); + 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"}); @@ -168,9 +168,18 @@ my($class,%args)=@_; do { args_check(%$_) if $_; } for ($W->{"args_check"}); + $ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}(); + return $W; } +sub Wprint($) +{ +my($text)=@_; + + $W->{"r"}->print($text); +} + sub top_dir_disk () { do { return $_ if $_; } for ($W->{"top_dir"}); @@ -181,7 +190,7 @@ sub top_dir (;$) { my($in)=@_; - if (my $uri=$ENV{"REQUEST_URI"}) { + if (my $uri=$W->{"r"}->unparsed_uri()) { if ($W->{"args"}{"Wabs"}) { # FIXME: $in may not be defined here! # to prevent: Use of uninitialized value in ... @@ -189,7 +198,7 @@ my($in)=@_; $in=~s#^/*##; } else { - $in=$ENV{"REQUEST_URI"}."/".$in; + $in=$uri."/".$in; $in=~tr#/#/#s; 1 while $in=~s#/(?:[^/]+)/\Q..\E/#/#g } @@ -231,7 +240,7 @@ my(%tmpl)=@_; $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; + $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)."" @@ -256,7 +265,7 @@ my($msg)=@_; $W->{"indexme"}=0; # For the case no heading was sent yet. My::Web->heading(); - print "\n".vskip("3ex")."

FATAL ERROR: $msg!

\n" + 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(); @@ -266,31 +275,39 @@ sub footer (;$) { exit 1 if $W->{"footer_passed"}++; # deadlock prevention: - print vskip if $W->{"footer_delimit"}; + Wprint vskip if $W->{"footer_delimit"}; if ($W->{"heading"}) { do { &{$_}() if $_; } for ($W->{"footing_delimit"}); } - print "
\n" if $W->{"footer"}; + Wprint "
\n" if $W->{"footer"}; if ($W->{"footer_mailme"}) { - print '
'."\n"; - print '

'."\n"; - print ''."\n"; - print ''."\n"; - print ''."\n"; - print '

'."\n"; - print '
'."\n"; + Wprint '

'."\n"; + Wprint ''."\n"; + Wprint ''."\n"; + Wprint ''."\n"; + Wprint '

'."\n"; + Wprint ''."\n"; } + my @packages_used=( + $W->{"__PACKAGE__"}, + __PACKAGE__, + @{$W->{"packages_used"}{"__My::Web"}}, + map((!$_ ? () : @$_),$W->{"packages_used"}{$W->{"__PACKAGE__"}}), + ); + my %packages_used; + @packages_used=grep((!$packages_used{$_}++),@packages_used); if ($W->{"footer_ids"}) { - print '

'; - print join("
\n",map({ my $package=$_; + Wprint '

'; + Wprint join("
\n",map({ my $package=$_; my $cvs_id=(eval('$'.$package."::CVS_ID") # || $package # debug ); @@ -304,10 +321,13 @@ sub footer (;$) my $file=$package; $file=~s#::#/#g; my $ext; + my @tried; for (qw(.html.pl .pl .pm),"") { $ext=$_; - last if -r top_dir_disk()."/$file$ext"; - cluck "Class file $file not found" if !$ext; + my $pathname=top_dir_disk()."/$file$ext"; + push @tried,$pathname; + last if -r $pathname; + cluck "Class file $file not found; tried: ".join(" ",@tried) if !$ext; } $file.=$ext; $cvs_id_split[2]="" @@ -319,30 +339,22 @@ sub footer (;$) } join " ",@cvs_id_split; } - } ( - $W->{"__PACKAGE__"}, - __PACKAGE__, - @{$W->{"packages_used"}{$Apache::Registry::curstash}}, - ))); - print "

\n"; + } @packages_used)); + Wprint "

\n"; } - for my $package ( - $W->{"__PACKAGE__"}, - __PACKAGE__, - @{$W->{"packages_used"}{$Apache::Registry::curstash}}, - ) { + for my $package (@packages_used) { my $cvs_id=(eval('$'.$package."::CVS_ID") # || $package # debug ); - print ''."\n" if $cvs_id; + Wprint ''."\n" if $cvs_id; } if ($W->{"heading"}) { do { &{$_}() if $_; } for ($W->{"footing"}); } - print "\n"; + Wprint "\n"; exit(0); } @@ -411,7 +423,7 @@ my($url,$contents,%args)=@_; $r.='"'; do { $r.=" $_" if $_; } for ($args{"attr"}); $r.='>'.$contents.''; - if ($args{"size"} && url_is_local($url) && $url=~/[.](?:gz|Z|rpm|zip|deb|lha)/) { # Downloadable? + if ($args{"size"} && url_is_local($url) && ($args{"size"}>=2 || $url=~/[.](?:gz|Z|rpm|zip|deb|lha)/)) { # Downloadable? $url=top_dir_disk().$url if $url=~m#^/#; if (!-r $url) { cluck "File not readable: $url"; } @@ -429,13 +441,14 @@ sub remote_ip () # As 'Apache::ForwardedFor' takes the first of $ENV{"HTTP_X_FORWARDED_FOR"} # while the contents is '127.0.0.1, 213.220.195.171' if client has its own proxy. # We must take the last item ourselves. - my $r=$ENV{"HTTP_X_FORWARDED_FOR"} || $W->{"r"}->get_remote_host(); + my $r=$W->{"r"}->headers_in()->{"X-Forwarded-For"} || $W->{"r"}->get_remote_host(); $r=~s/^.*,\s*//; return $r; } sub is_cz () { + return 0 if !$have_Geo_IP; return "CZ" eq Geo::IP->new()->country_code_by_addr(remote_ip()); } @@ -614,17 +627,17 @@ my($class)=@_; exit if $W->{"r"}->header_only(); if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn - print ''."\n"; + Wprint ''."\n"; } - print ''."\n"; - print ''."\n"; + Wprint ''."\n"; + Wprint ''."\n"; my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ()))); $title=~s#<[^>]*>##g; - print ""; - print "$title\n"; + Wprint ""; + Wprint "$title\n"; if ($W->{"have_css"}) { - print <<'HERE'; + Wprint <<'HERE'; \n"; + Wprint $W->{"head_css"}."\n"; + Wprint "-->\n"; } - print ''."\n"; - print $W->{"head"}; + Wprint ''."\n"; + Wprint $W->{"head"}; for my $type (qw(prev next index contents start up)) { - do { print ''."\n" if $_; } for ($W->{"rel_$type"}); + do { Wprint ''."\n" if $_; } for ($W->{"rel_$type"}); } - print "{"browser"}->netscape() && (!$W->{"browser"}->major() || $W->{"browser"}->major()<=4); - print ">\n"; + do { &{$_}($W) if $_; } for $W->{"body_attr_sub"}; + Wprint ">\n"; if ($W->{"heading"}) { do { &{$_}() if $_; } for ($W->{"heading"}); } } +BEGIN { + delete $W->{"__My::Web_init"}; + } + 1;