X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=89b56043db851199ea202c44ace871d6057debfe;hb=93b094f3c8d6530b0a543b3ee46e961503497a7f;hp=c368a4b649e75917a200d91801b7f26901e340fe;hpb=49b55060536a7345c0df34a1e97996ec3c4ccc4e;p=MyWeb.git diff --git a/Web.pm b/Web.pm index c368a4b..89b5604 100644 --- a/Web.pm +++ b/Web.pm @@ -31,7 +31,7 @@ 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 @@ -68,6 +68,8 @@ BEGIN for my $caller (keys(%callers)) { next if $caller eq $target; next if $packages_used_hash{$caller}{$target}++; + cluck "Appending to the '_done' package list: caller=$caller,target=$target" + if $packages_used_hash{$caller}{"_done"}; push @{$packages_used_array{$caller}},$target; } } @@ -104,49 +106,29 @@ 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; +require MIME::Base64; +use Apache2::ServerUtil; #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; - # 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 ($%) { @@ -225,17 +207,48 @@ 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(); }, + }), + ); + Wrequire 'My::Hash::Readonly'; + $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"}) { + # Do not: # Extend the current ETag system instead if you would need it: + # cluck "Explicitely NOT HTTP-Safe for method \"".$W->{"r"}->method()."\"?!?" + # if defined($$_) && !$$_; + # as sometimes it just does not make sense to cache it. + $$_=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); @@ -243,7 +256,7 @@ 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"}); @@ -251,7 +264,34 @@ my($class,%args)=@_; return bless $W,$class; } -# Although we have &tie-d *STDOUT we try to not to be dependent on it in My::Web itself. +sub cleanup($) +{ +my($apache_request)=@_; + + cluck "CORE::GLOBAL::exit hook not ran" if !$W->{"_exit_ran"}; + cluck "packages not finalized" if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}; + cache_finish(); + # Sanity protection. + $W=undef(); + return OK; +} + +# PerlResponseHandler is RUN_FIRST and &ModPerl::Util::exit returns OK, so no (sane) go. +# PerlLogHandler is already too late to be able to produce any output. +my $exit_orig=\&CORE::GLOBAL::exit; +sub exit_hook +{ + # &footer will call us recursively! + footer() if !$W->{"_exit_ran"}++; + return &{$exit_orig}(@_); +} +{ + # Prevent: Subroutine CORE::GLOBAL::exit redefined + no warnings 'redefine'; + *CORE::GLOBAL::exit=\&exit_hook; + } + +# 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"} @@ -263,7 +303,21 @@ 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; + # Do not: cluck "utf-8 untested" if Encode::is_utf8($text); + # as it is valid here. + $W->{"r"}->puts($text); +} + +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 escapeHTML($) @@ -284,24 +338,6 @@ my($text)=@_; return CGI::escapeHTML($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); -} - # /home/user/www/webdir sub dir_top_abs_disk() { @@ -378,13 +414,11 @@ my($in,%args)=@_; return $uri->rel(unparsed_uri()); } -my %path_abs_disk_for_package; # $path_abs_disk_for_package{$W->{"__PACKAGE__"}}{$path_abs_disk}=1; - sub path_abs_disk_register($) { my($path_abs_disk)=@_; - $path_abs_disk_for_package{$W->{"__PACKAGE__"}}{$path_abs_disk}=1; + $W->{"path_abs_disk_register"}{$path_abs_disk}=1; } # $args{"uri_as_in"}=1 to permit passing URI objects as: $in @@ -451,21 +485,26 @@ my($msg)=@_; Wprint "\n".vskip("3ex")."
You can report this problem's details to" ." ".a_href("mailto:".$W->{"admin_mail"},"admin of this website").".
\n"; - footer(); + exit; } -sub footer (;$) +sub footer() { - exit 1 if $W->{"footer_passed"}++; # deadlock prevention: + cluck 'Explicit &footer call is deprecated' if !$W->{"_exit_ran"}; + exit if $W->{"footer_passed"}++; # deadlock prevention: + if ($W->{"header_only"}) { + $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; + exit; + } Wprint vskip if $W->{"footer_delimit"}; - - do { Wprint $_ if $_; } for $W->{"footing_delimit"}; - + &{$_}() for reverse @{$W->{"footing_delimit_sub_push"}}; Wprint "';
Wprint join("
\n",map({ my $package=$_;
@@ -514,20 +553,17 @@ sub footer (;$)
do { Wprint $_ if $_; } for $W->{"footing"};
Wprint "