X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=456e7c8bcfd721d12166e2aa86d985469d83e829;hp=0d4625be6621a723d176dd92f1f1554a5e163c35;hb=1ee642491d049abd3ee7324f395940f1650436bf;hpb=da7528a22d2ecfc06b853537add2edb2c245c443 diff --git a/Web.pm b/Web.pm index 0d4625b..456e7c8 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 @ISA=qw(Exporter); +our @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img ¢erimg &rightimg $W &top_dir &top_dir_disk &Wprint &input_hidden_persistents); +our @ISA=qw(Exporter Tie::Handle); BEGIN { + $W->{"__My::Web_init"}=1; + sub Wrequire ($) { my($file)=@_; @@ -42,9 +44,13 @@ BEGIN 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. + my $who=$W->{"__PACKAGE__"}; + $who||="__My::Web" if $W->{"__My::Web_init"}; + if ($who) { + my $aref=($W->{"packages_used"}{$who}||=[]); + push @$aref,$class + if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. + } CORE::require $file; 1; # Otherwise 'require' would already file above. } @@ -69,53 +75,54 @@ 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); +use POSIX qw(strftime); +use Tie::Handle; +use Apache::Const qw(HTTP_MOVED_TEMPORARILY); +use URI; +use URI::QueryParam; #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->{"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'; 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"); + do { $W->{$_}="" if !defined $W->{$_}; } for ("body_attr"); + do { $W->{$_}="en-US" if !defined $W->{$_}; } for ("language"); my $footer_any=0; for (qw(footer_mailme footer_ids)) { @@ -128,37 +135,40 @@ my($class,%args)=@_; $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"; + 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_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"}; + # 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()->Vars() }; - for (keys(%{$W->{"args"}})) { - my @vals=split /\x00/,$W->{"args"}{$_}; + $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"}{$_}=[@vals]; + $W->{"args"}{$name}=[@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"}); if (!defined $W->{"have_style"}) { - $W->{"have_style"}=(!$W->{"browser"}->netscape() || $W->{"browser"}->major>4 ? 1 : 0); + $W->{"have_style"}=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0); } $W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0); @@ -168,7 +178,34 @@ my($class,%args)=@_; do { args_check(%$_) if $_; } for ($W->{"args_check"}); - return $W; + $ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}(); + + return bless $W,$class; +} + +sub Wprint($) +{ +my($text)=@_; + + $W->{"r"}->puts($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); } sub top_dir_disk () @@ -177,11 +214,25 @@ sub top_dir_disk () return $INC[0]; # fallback } -sub top_dir (;$) +# $args{"abs"} +sub top_dir (;$%) { -my($in)=@_; - - if (my $uri=$ENV{"REQUEST_URI"}) { +my($in,%args)=@_; + + if (my $uri=$W->{"r"}->unparsed_uri()) { + if ($W->{"args"}{"Wabs"} || $args{"abs"}) { + # FIXME: $in may not be defined here! + # to prevent: Use of uninitialized value in ... + if ($in=~m#^/#) { + $in=~s#^/*##; + } + else { + $in=$uri."/".$in; + $in=~tr#/#/#s; + 1 while $in=~s#/(?:[^/]+)/\Q..\E/#/#g + } + return "http://".&{$W->{"web_hostname_sub"}}()."/".(defined $in ? $in : ""); + } $uri.="Index" if $uri=~m#/$#; if (defined $in) { my($inpath,$inquery)=split /[?]/,$in,2; @@ -218,7 +269,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)."" @@ -240,10 +291,13 @@ sub fatal (;$) my($msg)=@_; $msg="UNKNOWN" if !$msg; + cluck "FATAL: $msg"; $W->{"indexme"}=0; # For the case no heading was sent yet. + $W->{"heading_done"}=0; # for the case of already sent {"header_only"}==1 + $W->{"header_only"}=0; # assurance for &heading 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(); @@ -253,31 +307,38 @@ 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"}); - } + 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 input_hidden_persistents()."\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 ); @@ -291,10 +352,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]="" @@ -306,30 +370,20 @@ 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"}); - } + do { &{$_}() if $_; } for ($W->{"footing"}); - print "\n"; + Wprint "\n"; exit(0); } @@ -368,16 +422,42 @@ my($url)=@_; return $url!~m#^[a-z]+://#; } +sub url_out($%) +{ +my($url,%args)=@_; + + return $url if !url_is_local $url; + $url=top_dir($url,%args) if $url=~m#^/# || $args{"abs"}; + + my $uri=URI->new($url); + # 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()}, + }); + $url="".$uri; + + return $url; +} + sub a_href ($;$%) { my($url,$contents,%args)=@_; do { $$_=1 if !defined $$_; } for (\$args{"size"}); - $contents=CGI::escapeHTML($url) if !defined $contents; + if (!defined $contents) { + $contents=$url; + $contents=File::Basename::basename($contents) if $args{"basename"}; + $contents=CGI::escapeHTML($contents); + } $contents=~s#]*>##gi; $contents=~s###gi; - $url=top_dir($url) if url_is_local $url && $url=~m#^/#; + $url=url_out($url,%args); my $r=''; - 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"; } @@ -405,6 +485,32 @@ my($url,$contents,%args)=@_; return $r; } +sub input_hidden_persistents() +{ + return join("",map({ + my $key=$_; + my $val=$W->{"args"}{$key}; + (!defined $val ? () : ''."\n"); + } (keys(%{$W->{"args_persistent"}})))); +} + +sub http_moved($$;$) +{ +my($self,$url,$status)=@_; + + $url=url_out($url,"abs"=>1); + $status||=Apache::HTTP_MOVED_TEMPORARILY; + $W->{"r"}->status($status); + $W->{"r"}->header_out("Location"=>$url); + $W->{"header_only"}=1; + My::Web->heading(); + exit; + die "NOTREACHED"; +} + sub remote_ip () { # Do not: PerlModule Apache::ForwardedFor @@ -412,13 +518,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()); } @@ -453,9 +560,28 @@ my(%args)=@_; return [ map(($args{$_}),@fields) ]; } +# Input: $self is required! +# Input: Put the fallback variant as the first one. +# Returns: always only scalar! +sub Negotiate_choose($$) +{ +my($self,$variants)=@_; + + my $best=HTTP::Negotiate::choose($variants, + # Do not: $W->{"r"} + # to prevent: Can't locate object method "scan" via package "Apache::RequestRec" at HTTP/Negotiate.pm line 84. + # Do not: $W->{"r"}->headers_in() + # to prevent: Can't locate object method "scan" via package "APR::Table" at HTTP/Negotiate.pm line 84. + # Do not: HTTP::Headers->new($W->{"r"}->headers_in()); + # to prevent empty result or even: Odd number of elements in anonymous hash + HTTP::Headers->new(%{$W->{"r"}->headers_in()})); + $best||=$variants->[0]{"id"}; # &HTTP::Negotiate::choose failed? + return $best; +} + my @img_variants=( - { "id"=>"png","qs"=>1.0,"content-type"=>"image/png" }, - { "id"=>"gif","qs"=>0.9,"content-type"=>"image/gif" }, + { "id"=>"png","qs"=>0.9,"content-type"=>"image/png" }, + { "id"=>"gif","qs"=>0.7,"content-type"=>"image/gif" }, ); my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$'; @@ -496,10 +622,7 @@ my($file_base)=@_; "size"=>(stat $file)[7], ); } - # Do not: ,$W->{"r"}); - # but should we provide somehow either 'HTTP::Headers' or 'HTTP::Request' ? - my $ext=HTTP::Negotiate::choose(\@nego_variants); - $ext||=$img_variants[0]->{"id"}; # &HTTP::Negotiate::choose failed? + my $ext=__PACKAGE__->Negotiate_choose(\@nego_variants); return $file_base_uri.".".$ext if !wantarray(); return ($file_base_uri.".".$ext,$file_base_disk.".".$ext); @@ -577,73 +700,97 @@ my(@arr)=@_; return @r; } +sub no_cache($) +{ +my($self)=@_; + + header("Expires"=>"Mon, 26 Jul 1997 05:00:00 GMT"); # date in the past + header("Last-Modified"=>strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime())); # always modified + header("Cache-Control"=>"no-cache, must-revalidate"); # HTTP/1.1 + header("Pragma"=>"no-cache"); # HTTP/1.0 +} + sub heading () { my($class)=@_; - return if $W->{"heading_passed"}++; - # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!) my $client_charset=$W->{"force_charset"} || "us-ascii"; header("Content-Style-Type"=>"text/css"); header("Content-Script-Type"=>"text/javascript"); + do { header("Content-Language"=>$_) if $_; } for $W->{"language"}; + $class->no_cache() if $W->{"no_cache"}; while (my($key,$val)=each(%{$W->{"headers"}})) { $W->{"r"}->header_out($key,$val); } - $W->{"r"}->send_http_header("text/html; charset=$client_charset"); # "Content-type"; do not use header() - - return if $W->{"heading_done"}++; exit if $W->{"r"}->header_only(); + return if $W->{"header_only"}; + # We still can append headers before we put out some text. + # FIXME: It is not clean to still append them without overwriting. + return if $W->{"heading_done"}++; + my $lang=($W->{"language"}||"en-US"); + # Workaround bug + # https://bugzilla.mozilla.org/show_bug.cgi?id=120556 + # of at least + # Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217 + my $mime=$class->Negotiate_choose([ + # Put the fallback variant as the first one. + # Rate both variants the same to prefer "text/html" for undecided clients. + # At least + # Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217 + # prefers "application/xhtml+xml" over "text/html" itself: + # text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 + negotiate_variant( + "id"=>"text/html", + "content-type"=>"text/html", + "qs"=>0.6, + "charset"=>$client_charset, + "lang"=>$lang, + ), + negotiate_variant( + "id"=>"application/xhtml+xml", + "content-type"=>"application/xhtml+xml", + "qs"=>0.6, + "charset"=>$client_charset, + "lang"=>$lang, + ), + # application/xml ? + # text/xml ? + ]); + $W->{"r"}->send_http_header("$mime; charset=$client_charset"); # "Content-type"; do not use header() 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'; -\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<=4; - print ">\n"; + Wprint "{"browser"}->netscape() && (!$W->{"browser"}->major() || $W->{"browser"}->major()<=4); + Wprint $W->{"body_attr"}; + Wprint ">\n"; - if ($W->{"heading"}) { - do { &{$_}() if $_; } for ($W->{"heading"}); - } + do { &{$_}() if $_; } for ($W->{"heading"}); } +BEGIN { + delete $W->{"__My::Web_init"}; + } + 1;