X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=33cd6d97984d78047710bd49a0fafe511ad26809;hp=3eb176bc1d93e748ad4971464830e55dbc3ae8cc;hb=75226de30be9f3e3fb61c71b2f0c7ba4ba22d4ab;hpb=3f4bb50b019115eb59282928c7eea99c3d2a7b2d diff --git a/Web.pm b/Web.pm index 3eb176b..33cd6d9 100644 --- a/Web.pm +++ b/Web.pm @@ -31,14 +31,18 @@ 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; # $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; +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,36 +97,56 @@ 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); +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->{'packages_used@'}{callers...}} - # %{$W->{'packages_used%'}{callers...}} - # %{$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 ($%) { @@ -134,31 +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'; - 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(); + $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)) { @@ -170,6 +196,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; @@ -195,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); @@ -213,17 +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"}); - - $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. +# 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)=@_; @@ -231,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); } @@ -286,13 +357,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 +387,7 @@ my($in)=@_; } # $args{"uri_as_in"}=1 to permit passing URI objects as: $in +# $args{"abs"}=1; sub path_web($%) { my($in,%args)=@_; @@ -336,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($%) { @@ -346,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)=@_; @@ -407,11 +489,11 @@ 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->{'packages_used@'}{$W->{"__PACKAGE__"}}; + my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; if ($W->{"footer_ids"}) { Wprint '

'; @@ -458,23 +540,20 @@ sub footer (;$) Wprint ''."\n" if $cvs_id; } - Wprint $W->{"footing"},"undef"=>1; + do { Wprint $_ if $_; } for $W->{"footing"}; Wprint "\n"; exit 0; } -sub header (%) +# Existing entries are overwritten. +sub header(%) { my(%pairs)=@_; while (my($key,$val)=each(%pairs)) { do { cluck "Headers already sent"; next; } if $W->{"heading_done"}; - for ($W->{"headers_lc"}{lc $key} || ()) { - delete $W->{"headers"}{$_}; - } - $W->{"headers_lc"}{lc $key}=$key; - $W->{"headers"}{$key}=$val; + $W->{"r"}->headers_out()->set($key,$val); } } @@ -512,6 +591,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 @@ -519,10 +599,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; @@ -531,6 +613,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=""; @@ -547,8 +630,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}; @@ -580,23 +672,28 @@ 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->{"r"}->headers_in()->{"X-Forwarded-For"} || $W->{"r"}->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(); - return $contents; + my $cc; + $cc||=Geo::IP->new()->country_code_by_addr(remote_ip()) if $have_Geo_IP; + $cc||=""; + $url=$url->{$cc}; + return $contents if !$url; + return a_href $url,$contents,%args; } sub make ($) @@ -646,6 +743,13 @@ sub Negotiate_choose($$) { my($self,$variants)=@_; + # Limit these entries to generate proper 'Vary' header. + my %hash=(map(($_=>$W->{"headers_in"}{$_}),qw( + Accept + Accept-Charset + Accept-Encoding + Accept-Language + ))); my $best=HTTP::Negotiate::choose($variants, # Do not: $W->{"r"} # to prevent: Can't locate object method "scan" via package "Apache2::RequestRec" at HTTP/Negotiate.pm line 84. @@ -653,7 +757,7 @@ my($self,$variants)=@_; # to prevent: Can't locate object method "scan" via package "APR::Table" at HTTP/Negotiate.pm line 84. # 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()})); + HTTP::Headers->new(%hash)); $best||=$variants->[0][0]; # $variants->[0]{"id"}; &HTTP::Negotiate::choose failed? return $best; } @@ -672,7 +776,7 @@ my($in,%args)=@_; cluck if !uri_is_local $in; my $uri=in_to_uri_abs $in; - my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1; + my $path_abs_disk=path_abs_disk $uri,%args,"uri_as_in"=>1,"register"=>0; # Known image extension? return path_web($uri,%args,"uri_as_in"=>1),$path_abs_disk if $uri->path()=~m#$img_variants_re#o; @@ -680,6 +784,7 @@ my($in,%args)=@_; my @nego_variants; for my $var (@img_variants) { my $path_abs_disk_variant=$path_abs_disk.".".$var->{"id"}; + path_abs_disk_register($path_abs_disk_variant); __PACKAGE__->make_file($path_abs_disk_variant); push @nego_variants,negotiate_variant( %$var, @@ -697,6 +802,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; @@ -753,35 +859,196 @@ my($class,$filename)=@_; return $F; } -sub no_cache($) +sub _no_cache($) { my($self)=@_; - header("Expires"=>"Mon, 26 Jul 1997 05:00:00 GMT"); # date in the past - header("Last-Modified"=>strftime("%a, %d %b %Y %H:%M:%S GMT",gmtime())); # always modified - header("Cache-Control"=>"no-cache, must-revalidate"); # HTTP/1.1 + header("Expires"=>HTTP::Date::time2str(1000000000)); # date in the past + header("Last-Modified"=>HTTP::Date::time2str()); # always modified + header("Cache-Control"=>join(", ", + "no-cache", + "no-store", + "must-revalidate", + "max-age=0", + "pre-check=0", # MSIE + "post-check=0", # MSIE + )); # HTTP/1.1 header("Pragma"=>"no-cache"); # HTTP/1.0 + header("Vary"=>"*"); # content may ba based on unpredictable sources +} + +sub headers_in_filtered(@) +{ +my(@keys)=@_; + + return map(($_=>$W->{"headers_in"}{$_}),@keys); +} + +our %uri_args_frozen_to_headers_in_keys; +our %uri_args_headers_in_frozen_to_headers_out; + +sub uri_args_headers_in_frozen_get($) +{ +my($headers_in_keys_arrayref)=@_; + + my %uri_args_headers_in_hash=( + "uri_args_frozen"=>$W->{"uri_args_frozen"}, + "headers_in"=>{ headers_in_filtered(@$headers_in_keys_arrayref) }, + ); + return do { local $Storable::canonical=1; Storable::freeze(\%uri_args_headers_in_hash); }; +} + +sub cache_output_filter($) +{ +my($f)=@_; + + while ($f->read(my $text,0x400)) { + cluck "utf-8 untested" if Encode::is_utf8($text); # Possible here at all? + $f->print($text); + $W->{"digest-md5"}->add($text); + } + return OK; +} + +sub cache_start() +{ + if (!$W->{"http_safe"}) { + __PACKAGE__->_no_cache(); + return; + } + + { + # &Wrequire it here even if it will not be later used; to be stable! + Wrequire 'My::Hash::RestrictTo'; + my %uri_args_hash=( + "uri"=>"http://".$W->{"web_hostname"}."/".$W->{"r"}->uri(), + "args"=>$W->{"args_orig_array"}, + ); + $W->{"uri_args_frozen"}=do { local $Storable::canonical=1; Storable::freeze(\%uri_args_hash); }; + last if !(my $headers_in_keys_arrayref=$uri_args_frozen_to_headers_in_keys{$W->{"uri_args_frozen"}}); + + # Protection to be sure we are stable: + $W->{"headers_in"}=My::Hash::RestrictTo->new($W->{"headers_in"},@$headers_in_keys_arrayref); + + $W->{"uri_args_headers_in_frozen"}=uri_args_headers_in_frozen_get($headers_in_keys_arrayref); + last if !(my $headers_out_hashref=$uri_args_headers_in_frozen_to_headers_out{$W->{"uri_args_headers_in_frozen"}}); + header(%$headers_out_hashref); + my $status; + { + # &meets_conditions will always deny the attempt if !2xx status(). + # At least ap_read_request() sets: r->status=HTTP_REQUEST_TIME_OUT; /* Until we get a request */ + my $status_old=$W->{"r"}->status(); + $W->{"r"}->status(HTTP_OK); + # Update httpd's 'r->mtime' as the header "Last-Modified" is just not enough for ap_meets_conditions(): + # &update_mtime() argument is really in _secs_, not in _msecs_ as the docs claim. + # Be aware '*1000000' would overflow Perl integer anyway. + # &set_last_modified would also override the "Last-Modified" headers_out! + # &mtime may exist but somehow does not work. + $W->{"r"}->update_mtime(HTTP::Date::str2time($headers_out_hashref->{"Last-Modified"})); + $status=$W->{"r"}->meets_conditions(); + $W->{"r"}->status($status_old); + } + last if OK==$status; + $W->{"r"}->status($status); + exit 0; + die "NOTREACHED"; + } + + $W->{"digest-md5"}=Digest::MD5->new(); + $W->{"cache_active"}=1; + $W->{"r"}->add_output_filter(\&cache_output_filter); +} + +sub cache_finish_last_modified() +{ + cluck "Not yet done now? W __PACKAGE__: ".$W->{"__PACKAGE__"} + if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}; + for my $package_orig (@{$packages_used_array{$W->{"__PACKAGE__"}}}) { + local $_=$package_orig.".pm"; + s{::}{/}g; + path_abs_disk "/$_","register"=>1; + } + my $mtime_newest; + for my $path_abs_disk (keys(%{$W->{"path_abs_disk_register"}})) { + my $mtime=(stat $path_abs_disk)[9]; + do { cluck "No mtime for: $path_abs_disk"; next; } if !$mtime; + $mtime_newest=$mtime if !$mtime_newest || $mtime_newest<$mtime; + } + cluck "No mtime_newest found for the current W __PACKAGE__: ".$W->{"__PACKAGE__"} + if !$mtime_newest; + return HTTP::Date::time2str($mtime_newest); +} + + +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. + return if !$W->{"cache_active"}; + + # Fill-in/check: %uri_args_frozen_to_headers_in_keys + my $headers_in_keys_stored_arrayref_ref=\$uri_args_frozen_to_headers_in_keys{$W->{"uri_args_frozen"}}; + my @headers_in_keys=tied(%{$W->{"headers_in_RecordKeys"}})->accessed(); + if (!$$headers_in_keys_stored_arrayref_ref + || !Data::Compare::Compare(\@headers_in_keys,$$headers_in_keys_stored_arrayref_ref)) { + cluck "Non-matching generated 'headers_in_keys' per 'uri_args_frozen' key:\n" + .Dumper(\@headers_in_keys,$$headers_in_keys_stored_arrayref_ref) + if $$headers_in_keys_stored_arrayref_ref; + # Build or possibly prevent such further warn dupes: + $$headers_in_keys_stored_arrayref_ref=\@headers_in_keys; + # Build or regenerate as obsoleted now: + $W->{"uri_args_headers_in_frozen"}=uri_args_headers_in_frozen_get(\@headers_in_keys); + } + + # Prepare 'headers_out' for the future reusal: + my %headers_out; + $headers_out{"Content-MD5"}=$W->{"digest-md5"}->b64digest(); + # 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() ? + $headers_out{"ETag"}='"'.Digest::MD5::md5_base64($W->{"uri_args_headers_in_frozen"}).'"'; + # $W->{"r"}->set_content_length() ? + $headers_out{"Content-Length"}=$W->{"r"}->bytes_sent(); + my %Vary=map(($_=>1),(@headers_in_keys)); + for (keys(%Vary)) { + next if !/^_/; + $Vary{"*"}=1; + delete $Vary{$_}; + } + %Vary=("*"=>1) if $Vary{"*"}; + $headers_out{"Vary"}=join(", ",sort keys(%Vary)); + # $W->{"r"}->set_last_modified() ? + $headers_out{"Last-Modified"}=cache_finish_last_modified(); + + # Fill-in/check: %uri_args_headers_in_frozen_to_headers_out + my $headers_out_stored_hashref_ref=\$uri_args_headers_in_frozen_to_headers_out{$W->{"uri_args_headers_in_frozen"}}; + if (!$$headers_out_stored_hashref_ref + || !Data::Compare::Compare(\%headers_out,$$headers_out_stored_hashref_ref)) { + cluck "Non-matching generated 'headers_out' per 'uri_args_headers_in_frozen' key:\n" + .Dumper(\%headers_out,$$headers_out_stored_hashref_ref) + if $$headers_out_stored_hashref_ref; + # Build or possibly prevent such further warn dupes: + $$headers_out_stored_hashref_ref=\%headers_out; + } + +###print STDERR Dumper(\%uri_args_frozen_to_headers_in_keys,\%uri_args_headers_in_frozen_to_headers_out); } sub heading() { my($class)=@_; + if (!$W->{"header_only"}) { + header("Content-Style-Type"=>"text/css"); + header("Content-Script-Type"=>"text/javascript"); + # $W->{"r"}->content_languages() ? + do { header("Content-Language"=>$_) if $_; } for $W->{"language"}; + } + # TODO: Support also: private + header("Cache-Control"=>"public"); # HTTP/1.1 + # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!) my $client_charset=$W->{"force_charset"} || "us-ascii"; - header("Content-Style-Type"=>"text/css"); - header("Content-Script-Type"=>"text/javascript"); - do { header("Content-Language"=>$_) if $_; } for $W->{"language"}; - $class->no_cache() if $W->{"no_cache"}; - - while (my($key,$val)=each(%{$W->{"headers"}})) { - $W->{"r"}->headers_out()->{$key}=$val; - } - exit if $W->{"r"}->header_only(); - return if $W->{"header_only"}; - # We still can append headers before we put out some text. - # FIXME: It is not clean to still append them without overwriting. - return if $W->{"heading_done"}++; # Workaround bug # https://bugzilla.mozilla.org/show_bug.cgi?id=120556 @@ -789,7 +1056,9 @@ my($class)=@_; # Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217 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||="application/xhtml+xml" if 1 + && !$W->{"headers_in"}{"Accept"} + && ($W->{"headers_in"}{"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. @@ -814,20 +1083,39 @@ my($class)=@_; # application/xml ? # text/xml ? ]); + # mod_perl doc: If you set this header via the headers_out table directly, it + # will be ignored by Apache. So do not do that. $W->{"r"}->content_type("$mime; charset=$client_charset"); + + cache_start(); + return if $W->{"header_only"}; + # We still can append headers before we put out some text. + # FIXME: It is not clean to still append them without overwriting. + return if $W->{"heading_done"}++; + Wprint ''."\n" if $mime=~m{^application/\w+[+]xml$}; return if $W->{"xml_header_only"}; 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 + } + if ($W->{"css_inherit"}) { + Wprint <<"HERE"; +