X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=0cf0d3c86a82bf96c78feede5c3c74e853eca885;hb=d352d10efbc9a65e73c0dbf60753558b1010dc63;hp=3fdfdad26e459a39249270257643c1aa34e8c8e8;hpb=462946d181448abcd561def62cd171e30e5d5679;p=MyWeb.git diff --git a/Web.pm b/Web.pm index 3fdfdad..0cf0d3c 100644 --- a/Web.pm +++ b/Web.pm @@ -36,9 +36,13 @@ our @EXPORT=qw( &img ¢erimg &rightimg $W &input_hidden_persistents + &escapeHTML ); our @ISA=qw(Tie::Handle Exporter); +my %packages_used_hash; +my %packages_used_array; + BEGIN { use Carp qw(cluck confess); @@ -54,12 +58,18 @@ BEGIN my $class=$file; $file=~s#::#/#g; $file.=".pm"; - 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. + 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 $packages_used_hash{$caller}{$target}++; + push @{$packages_used_array{$caller}},$target; + } } eval { CORE::require "$file"; } or confess $@; 1; # Otherwise 'require' would already file above. @@ -75,11 +85,19 @@ BEGIN $file->import(@list); 1; } + + sub import + { + my($class,@rest)=@_; + + local $Exporter::ExportLevel=$Exporter::ExportLevel+1; + Wrequire("$class"); + return $class->SUPER::import(@rest); + } } -BEGIN { Wuse 'WebConfig'; } # for %WebConfig -BEGIN { Wuse 'My::Hash::Sub'; } -require CGI; # for &escapeHTML +use WebConfig; # see also below: Wuse 'WebConfig'; +require CGI; require Image::Size; # for &imgsize use File::Basename; # &basename use Carp qw(cluck confess); @@ -92,7 +110,7 @@ my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; } # I do not know why. use POSIX qw(strftime); use Tie::Handle; -use Apache2::Const qw(HTTP_MOVED_TEMPORARILY); +use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK); use URI; use URI::QueryParam; use Cwd; @@ -106,27 +124,53 @@ use Cwd; # $W->{"footer_passed"} # %{$W->{"headers"}} # %{$W->{"headers_lc"}} # maps lc($headers_key)=>$headers_key - # @{$W->{"packages_used"}{$W->{"__PACKAGE__"}}} - # @{$W->{"packages_used"}{"__My::Web"}} # %{$W->{"args"}} +sub cleanup($) +{ +my($apache_request)=@_; + + # Sanity protection. + $W=undef(); + return OK; +} + +sub request_check(;$) +{ +my($self)=@_; + + # 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 sensitive dynamic code from a static code" if !eval { Apache2::RequestUtil->request(); }; + # Do not: confess "Calling sensitive dynamic code without My::Web::init" if !$W->{"__PACKAGE__"}; + # as it is valid at least while preparing arguments to call: &project::Lib::init +} + sub init ($%) { my($class,%args)=@_; print STDERR "$class->init ".Apache2::RequestUtil->request()->unparsed_uri()."\n"; - my $packages_used_save=$W->{"packages_used"}; + # 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'; + $W={}; tie %$W,"My::Hash::Sub"; %$W=(%WebConfig,%args); # override %WebConfig settings - $W->{"packages_used"}=$packages_used_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__"; + # See: &escapeHTML + do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset(); + CGI::charset("utf-8"); + 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. @@ -148,6 +192,10 @@ my($class,%args)=@_; $W->{"r"}=Apache2::RequestUtil->request(); + $W->{"r"}->push_handlers("PerlCleanupHandler"=>\&cleanup); + + $W->{"web_hostname"}||=$W->{"r"}->hostname(); + tie *STDOUT,$W->{"r"}; select *STDOUT; $|=1; @@ -180,8 +228,8 @@ my($class,%args)=@_; $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"); + 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"}); @@ -194,14 +242,16 @@ my($class,%args)=@_; $W->{"head"}.=''."\n"; } - do { args_check(%$_) if $_; } for ($W->{"args_check"}); - - $ENV{"HOSTNAME"}||=$W->{"web_hostname"}; + do { _args_check(%$_) if $_; } for ($W->{"args_check"}); return bless $W,$class; } # Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself. +# Do not: Wprint $W->{"heading"},"undef"=>1; +# as we would need to undef() it to turn it off and it would get defaulted in such case. +# Do not: exists $W->{"heading"} +# as we use a lot of 'for $W->{"heading"}' which instantiates it with the value: undef() sub Wprint($%) { my($text,%args)=@_; @@ -216,9 +266,17 @@ 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(); }; + # Prevent &CGI::escapeHTML breaking utf-8 strings like: \xC4\x9B eq \x{11B} + # Prevent case if we run under mod_perl but still just initializing: + request_check() if $ENV{"MOD_PERL"}; + # Generally we are initialized from &init but we may be used without it without mod_perl + # and in such case check the change on all non-first invocations. + our $init; + if (!$ENV{"MOD_PERL"} && $init++) { + do { cluck "charset==$_" if $_ ne "utf-8"; } for CGI::charset(); + } + CGI::charset("utf-8"); + return CGI::escapeHTML($text); } @@ -264,13 +322,14 @@ sub dir_top_abs_disk() sub unparsed_uri() { + request_check(); 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"})."/"); + my $uri=URI->new_abs($uri_string,"http://".$W->{"web_hostname"}."/"); $W->{"unparsed_uri"}=$uri; } return $W->{"unparsed_uri"}; @@ -293,6 +352,7 @@ my($in)=@_; } # $args{"uri_as_in"}=1 to permit passing URI objects as: $in +# $args{"abs"}=1; sub path_web($%) { my($in,%args)=@_; @@ -329,7 +389,7 @@ my($in,%args)=@_; sub fatal (;$); -sub args_check (%) +sub _args_check (%) { my(%tmpl)=@_; @@ -385,18 +445,12 @@ sub footer (;$) Wprint vskip if $W->{"footer_delimit"}; - Wprint $W->{"footing_delimit"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing_delimit"}; Wprint "
\n" if $W->{"footer"}; - 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); + my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; + if ($W->{"footer_ids"}) { Wprint '

'; Wprint join("
\n",map({ my $package=$_; @@ -431,18 +485,18 @@ sub footer (;$) } join " ",@cvs_id_split; } - } @packages_used)); + } @$packages_used)); Wprint "

\n"; } - for my $package (@packages_used) { + for my $package (@$packages_used) { my $cvs_id=(eval('$'.$package."::CVS_ID") # || $package # debug ); Wprint ''."\n" if $cvs_id; } - Wprint $W->{"footing"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing"}; Wprint "\n"; exit 0; @@ -496,6 +550,7 @@ my($uri)=@_; cluck if !ref $uri; my $urient=escapeHTML($uri); return $uri if $uri eq $urient; + request_check(); return $urient if uri_is_local $uri; return $uri if defined $W->{"have_ent"} && !$W->{"have_ent"}; # non-ent client return $urient if $W->{"have_ent"}; # ent client @@ -503,10 +558,12 @@ my($uri)=@_; return escapeHTML(path_web('/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri())))); } +our $a_href_inhibited; sub a_href($;$%) { my($in,$contents,%args)=@_; + request_check(); do { $$_=1 if !defined $$_; } for (\$args{"size"}); if (!defined $contents) { $contents=$in; @@ -515,6 +572,7 @@ my($in,$contents,%args)=@_; } $contents=~s#]*>##gi; $contents=~s###gi; + return $contents if $a_href_inhibited; my $path_web=path_web $in,%args; my $r=""; @@ -531,8 +589,17 @@ my($in,$contents,%args)=@_; return $r; } +sub a_href_inhibit($$;@) +{ +my($self,$sub,@sub_args)=@_; + + local $a_href_inhibited=1; + return &{$sub}(@sub_args); +} + sub input_hidden_persistents() { + request_check(); return join("",map({ my $key=$_; my $val=$W->{"args"}{$key}; @@ -638,7 +705,7 @@ my($self,$variants)=@_; # 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? + $best||=$variants->[0][0]; # $variants->[0]{"id"}; &HTTP::Negotiate::choose failed? return $best; } @@ -681,6 +748,7 @@ sub img ($$%) { my($in,$alt,%args)=@_; + request_check(); my($path_web,$path_abs_disk)=_img_src($in,%args); my($width,$height)=Image::Size::imgsize($path_abs_disk); $alt=~s/<[^>]*>//g; @@ -767,12 +835,14 @@ my($class)=@_; # 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([ + my $mime; + # http://validator.w3.org/ does not send ANY "Accept" headers! + $mime||="application/xhtml+xml" if !$W->{"accept"} && $W->{"user_agent"}=~m{^W3C_Validator/}i; + $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 @@ -784,33 +854,37 @@ my($class)=@_; "content-type"=>"text/html", "qs"=>0.6, "charset"=>$client_charset, - "lang"=>$lang, + "lang"=>$W->{"language"}, ), negotiate_variant( "id"=>"application/xhtml+xml", "content-type"=>"application/xhtml+xml", "qs"=>0.6, "charset"=>$client_charset, - "lang"=>$lang, + "lang"=>$W->{"language"}, ), # application/xml ? # text/xml ? ]); $W->{"r"}->content_type("$mime; charset=$client_charset"); - if (1) { # (|| !$msie_major || $msie_major>=4) # TODO:dyn - Wprint ''."\n"; - } + Wprint ''."\n" if $mime=~m{^application/\w+[+]xml$}; + return if $W->{"xml_header_only"}; Wprint ''."\n"; - Wprint ''."\n"; + Wprint ''."\n"; my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ()))); + # Do not: cluck if $title=~/[<>]/; + # as it is not solved just by: &a_href_inhibit + # as sometimes titles use also: ... $title=~s#<[^>]*>##g; Wprint ""; Wprint "$title\n"; if ($W->{"have_css"}) { # Everything can get overriden later. - Wprint <<"HERE"; - + for my $css ("/My/Web.css",map((!$_ ? () : ("ARRAY" ne ref($_) ? $_ : @$_)),$W->{"css_push"})) { + Wprint <<"HERE"; + HERE + } } Wprint ''."\n"; Wprint $W->{"head"}; @@ -824,7 +898,7 @@ HERE Wprint $W->{"body_attr"}; Wprint ">\n"; - Wprint $W->{"heading"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"heading"}; } BEGIN {