X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=0cf0d3c86a82bf96c78feede5c3c74e853eca885;hb=d352d10efbc9a65e73c0dbf60753558b1010dc63;hp=3eb176bc1d93e748ad4971464830e55dbc3ae8cc;hpb=3f4bb50b019115eb59282928c7eea99c3d2a7b2d;p=MyWeb.git diff --git a/Web.pm b/Web.pm index 3eb176b..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); @@ -63,8 +67,8 @@ BEGIN 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; + next if $packages_used_hash{$caller}{$target}++; + push @{$packages_used_array{$caller}},$target; } } eval { CORE::require "$file"; } or confess $@; @@ -93,7 +97,7 @@ BEGIN } use WebConfig; # see also below: Wuse 'WebConfig'; -require CGI; # for &escapeHTML +require CGI; require Image::Size; # for &imgsize use File::Basename; # &basename use Carp qw(cluck confess); @@ -106,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; @@ -120,10 +124,28 @@ use Cwd; # $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 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)=@_; @@ -136,19 +158,19 @@ my($class,%args)=@_; 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__"; + # 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. @@ -170,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; @@ -216,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)=@_; @@ -238,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); } @@ -286,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"}; @@ -315,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)=@_; @@ -351,7 +389,7 @@ my($in,%args)=@_; sub fatal (;$); -sub args_check (%) +sub _args_check (%) { my(%tmpl)=@_; @@ -407,11 +445,11 @@ sub footer (;$) Wprint vskip if $W->{"footer_delimit"}; - Wprint $W->{"footing_delimit"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing_delimit"}; Wprint "
'; @@ -458,7 +496,7 @@ sub footer (;$) Wprint ''."\n" if $cvs_id; } - Wprint $W->{"footing"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing"}; Wprint "