X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=33cd6d97984d78047710bd49a0fafe511ad26809;hp=dcd40ea3d04801141c029bd02c4d7d558fea487d;hb=75226de30be9f3e3fb61c71b2f0c7ba4ba22d4ab;hpb=ac46fdaeb2f2200a778ef25fbee8ec28317be8bd diff --git a/Web.pm b/Web.pm index dcd40ea..33cd6d9 100644 --- a/Web.pm +++ b/Web.pm @@ -31,15 +31,16 @@ our @EXPORT=qw( &Wrequire &Wuse &path_web &path_abs_disk &uri_escaped - &a_href &a_href_cz + &a_href &a_href_cc &vskip &img ¢erimg &rightimg $W &input_hidden_persistents + &escapeHTML ); our @ISA=qw(Tie::Handle Exporter); -my %packages_used_hash; +my %packages_used_hash; # $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; my %packages_used_array; BEGIN @@ -96,44 +97,57 @@ 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); use URI::Escape; require HTTP::BrowserDetect; require HTTP::Negotiate; -my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; } +our $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 OK); +use Apache2::Const qw(HTTP_MOVED_TEMPORARILY OK HTTP_OK); use URI; use URI::QueryParam; use Cwd; +require HTTP::Date; +require Storable; +require Digest::MD5; +require Data::Compare; +use Data::Dumper; +require Encode; +use Apache2::Filter; +use Apache2::Connection; #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->{"args"}} sub cleanup($) { my($apache_request)=@_; + $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; + cache_finish(); # 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)=@_; @@ -144,27 +158,33 @@ my($class,%args)=@_; # 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'; + Wrequire 'My::Hash'; - $W={}; - tie %$W,"My::Hash::Sub"; - %$W=(%WebConfig,%args); # override %WebConfig settings - $W->{"__PACKAGE__"}||=caller(); + $W=My::Hash->new({ + "__PACKAGE__"=>scalar(caller()), + %WebConfig, + %args, # override %WebConfig settings + },"My::Hash::Sub","My::Hash::Push"); # {"__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"); + # 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. + do { $W->{$_}=0 if !defined $W->{$_}; } for "css_inherit"; + 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)) { @@ -205,17 +225,46 @@ my($class,%args)=@_; 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() }; + $W->{"args_orig_array"}=[ CGI->new($W->{"r"})->Vars() ]; + $W->{"args"}={ @{$W->{"args_orig_array"}} }; 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->{"headers_in"}=$W->{"r"}->headers_in(); + Wrequire 'My::Hash::Merge'; + $W->{"headers_in"}=My::Hash::Merge->new( + $W->{"headers_in"}, + My::Hash::Sub->new({ + "_remote_ip"=>sub { return $W->{"r"}->connection()->remote_ip(); }, + }), + ); + $W->{"headers_in"}=My::Hash::Readonly->new($W->{"headers_in"}); + + if ($W->{"r"}->method() eq "GET" || $W->{"r"}->method() eq "HEAD") { + for (\$W->{"http_safe"}) { + # Extend the current ETag system instead if you would need it: + cluck "Explicitely NOT HTTP-Safe for method \"".$W->{"r"}->method()."\"?!?" + if defined($$_) && !$$_; + $$_=1 if !defined $$_; + } + } + else { + for (\$W->{"http_safe"}) { + cluck "Undefined HTTP-Safe-ty for method \"".$W->{"r"}->method()."\"!" + if !defined($$_); + $$_=0 if !defined $$_; + } + } + if ($W->{"http_safe"}) { + Wrequire 'My::Hash::RecordKeys'; + $W->{"headers_in_RecordKeys"}=My::Hash::RecordKeys->new($W->{"headers_in"}); + $W->{"headers_in"}=$W->{"headers_in_RecordKeys"}; + } - $W->{"browser"}=HTTP::BrowserDetect->new($W->{"user_agent"}); + $W->{"browser"}=HTTP::BrowserDetect->new($W->{"headers_in"}{"User-Agent"}); if (!defined $W->{"have_style"}) { $W->{"have_style"}=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0); @@ -223,15 +272,19 @@ my($class,%args)=@_; $W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0); if ($W->{"detect_js"} && !$W->{"have_js"}) { - $W->{"head"}.=''."\n"; + $W->{"head"}.=''."\n"; } - do { args_check(%$_) if $_; } for ($W->{"args_check"}); + 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. +# Be aware other parts of code (non-My::Web) will NOT use this function! +# 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)=@_; @@ -239,16 +292,26 @@ 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; + return if !defined $text; + cluck "utf-8 untested" if Encode::is_utf8($text); + $W->{"r"}->puts($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(); }; + # 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); } @@ -294,6 +357,7 @@ 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 @@ -345,6 +409,13 @@ my($in,%args)=@_; return $uri->rel(unparsed_uri()); } +sub path_abs_disk_register($) +{ +my($path_abs_disk)=@_; + + $W->{"path_abs_disk_register"}{$path_abs_disk}=1; +} + # $args{"uri_as_in"}=1 to permit passing URI objects as: $in sub path_abs_disk($%) { @@ -355,12 +426,14 @@ my($in,%args)=@_; 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; + my $r=dir_top_abs_disk().$path; + path_abs_disk_register $r if !defined $args{"register"} || $args{"register"}; + return $r; } sub fatal (;$); -sub args_check (%) +sub _args_check (%) { my(%tmpl)=@_; @@ -416,7 +489,7 @@ sub footer (;$) Wprint vskip if $W->{"footer_delimit"}; - Wprint $W->{"footing_delimit"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing_delimit"}; Wprint "