X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=89b56043db851199ea202c44ace871d6057debfe;hb=93b094f3c8d6530b0a543b3ee46e961503497a7f;hp=f9d6d62507e56413e29d635847c39f5ade3d33eb;hpb=cd853c0664010679a7015ba21831d56802be8455;p=MyWeb.git diff --git a/Web.pm b/Web.pm index f9d6d62..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; } } @@ -121,32 +123,13 @@ require Data::Compare; use Data::Dumper; require Encode; use Apache2::Filter; +use Apache2::Connection; +require MIME::Base64; +use Apache2::ServerUtil; #our $W; -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)=@_; @@ -237,16 +220,18 @@ my($class,%args)=@_; $W->{"headers_in"}=My::Hash::Merge->new( $W->{"headers_in"}, My::Hash::Sub->new({ - "_get_remote_host"=>sub { return $W->{"r"}->get_remote_host(); }, + "_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"}) { - # Extend the current ETag system instead if you would need it: - cluck "Explicitely NOT HTTP-Safe for method \"".$W->{"r"}->method()."\"?!?" - if defined($$_) && !$$_; + # 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 $$_; } } @@ -271,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"}); @@ -279,6 +264,33 @@ my($class,%args)=@_; return bless $W,$class; } +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. @@ -292,10 +304,22 @@ my($text,%args)=@_; delete $args{"undef"}; cluck join(" ","Invalid arguments:",keys(%args)) if keys(%args); return if !defined $text; - cluck "utf-8 untested" if Encode::is_utf8($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($) { my($text)=@_; @@ -314,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() { @@ -479,21 +485,26 @@ my($msg)=@_; 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(); + 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 "
\n" if $W->{"footer"}; - my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; + # Never update the package list while we examine it! + $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; + my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; if ($W->{"footer_ids"}) { Wprint '

'; Wprint join("
\n",map({ my $package=$_; @@ -542,7 +553,7 @@ sub footer (;$) do { Wprint $_ if $_; } for $W->{"footing"}; Wprint "\n"; - exit 0; + exit; } # Existing entries are overwritten. @@ -595,7 +606,7 @@ my($uri)=@_; return $uri if defined $W->{"have_ent"} && !$W->{"have_ent"}; # non-ent client return $urient if $W->{"have_ent"}; # ent client # Unknown client, &escapeHTML should not be needed here: - return escapeHTML(path_web('/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri())))); + return escapeHTML(path_web('/My/Redirect.pm?location='.uri_escape($uri->abs(unparsed_uri())))); } our $a_href_inhibited; @@ -671,22 +682,29 @@ sub remote_ip () # As 'Apache2::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=$W->{"headers_in"}{"X-Forwarded-For"} || $W->{"headers_in"}{"_get_remote_host"}; - $r=~s/^.*,\s*//; + # Be VERY sure you always retrieve all the headers unconditionally to hit: My::Hash::RecordKeys + my $x_forwarded_for=$W->{"headers_in"}{"X-Forwarded-For"}; + $x_forwarded_for=~s/^.*,\s*// if $x_forwarded_for; + my $remote_ip=$W->{"headers_in"}{"_remote_ip"}; + my $r; + $r||=$x_forwarded_for; + $r||=$remote_ip; return $r; } -sub is_cz () -{ - return 0 if !$have_Geo_IP; - return "CZ" eq Geo::IP->new()->country_code_by_addr(remote_ip()); -} - -sub a_href_cz ($$;%) +# $url={"JP"=>"http://specific",...}; +# $url={""=>"http://default",...}; +sub a_href_cc($$;%) { my($url,$contents,%args)=@_; - return a_href $url,$contents,%args if is_cz(); + # A bit ineffective but we must process all the possibilities to get stable 'headers_in' hits! + my %map=map(($_=>a_href($url->{$_},$contents,%args)),keys(%$url)); + my $cc; + $cc||=Geo::IP->new()->country_code_by_addr(remote_ip()) if $have_Geo_IP; + $cc||=""; + my $r=$map{$cc}; + return $r if $r; return $contents; } @@ -944,7 +962,8 @@ sub cache_start() } last if OK==$status; $W->{"r"}->status($status); - exit 0; + $W->{"header_only"}=1; # Inhibit &footer output. + exit; die "NOTREACHED"; } @@ -977,7 +996,7 @@ sub cache_finish_last_modified() sub cache_finish() { # Do not: return if !$W->{"uri_args_frozen"}; - # as we may have just gave 304 and 'exit 0;' without starting the caching. + # as we may have just gave 304 and 'exit;' without starting the caching. return if !$W->{"cache_active"}; # Fill-in/check: %uri_args_frozen_to_headers_in_keys @@ -996,7 +1015,13 @@ sub cache_finish() # Prepare 'headers_out' for the future reusal: my %headers_out; - $headers_out{"Content-MD5"}=$W->{"digest-md5"}->b64digest(); + # Do not: $W->{"digest-md5"}->b64digest(); + # as it will not provide the trailing filling '='s. + # RFC 1864 is not clear if they should be there but its sample provides them. + # Do not try to provide canonical "\r\n" form of newlines as is said by RFC 1864. + # RFC 2068 (HTTP/1.1) section 14.16 says the newlines should NOT be converted for HTTP. + # ',""' to avoid breaking the headers by its default "\n". + $headers_out{"Content-MD5"}=MIME::Base64::encode_base64($W->{"digest-md5"}->digest(),""); # In fact we could also use MD5 for ETag as if we know ETag we also know MD5. # But this way we do not need to calculate MD5 and we still can provide such ETag. So. # $W->{"r"}->set_etag() ? @@ -1100,7 +1125,7 @@ my($class)=@_; Wprint "$title\n"; if ($W->{"have_css"}) { # Everything can get overriden later. - for my $css ("/My/Web.css",map((!$_ ? () : ("ARRAY" ne ref($_) ? $_ : @$_)),$W->{"css_push"})) { + for my $css ("/My/Web.css",@{$W->{"css_push"}}) { Wprint <<"HERE"; HERE