X-Git-Url: http://git.jankratochvil.net/?a=blobdiff_plain;f=Web.pm;h=1a3f9e0a072f9d1f3f7d85b4d091bb9e9e67f0dc;hb=6c5cf4306de5fcb4958519e0f73cac52fea32753;hp=386f7696e6c2167da25d5dd1429bda0aa9e28bd3;hpb=ba64ae46b5228420d3807a8ee9e81f2e2fdef57d;p=MyWeb.git diff --git a/Web.pm b/Web.pm index 386f769..1a3f9e0 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; } } @@ -97,14 +99,13 @@ BEGIN } use WebConfig; # see also below: Wuse 'WebConfig'; -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. @@ -121,32 +122,15 @@ require Data::Compare; use Data::Dumper; require Encode; use Apache2::Filter; +use Apache2::Connection; +require MIME::Base64; +use Apache2::ServerUtil; +require MIME::Types; +require MIME::Parser; #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)=@_; @@ -159,19 +143,22 @@ my($class,%args)=@_; Wuse 'WebConfig'; Wrequire 'My::Hash'; - $W=My::Hash->new({ + # $W={} can get somehow created very easily. + # Do not: cluck "W not empty:\n".Dumper($W) if keys(%$W); + # to prevent (of $W->{"headers_in"}): TODO: Enumeration may not be expected. + cluck "W not empty; __PACKAGE__ was: ".$W->{"__PACKAGE__"} if keys(%$W); + $W=My::Hash->new({},"My::Hash::Sub","My::Hash::Push"); + bless $W,$class; + %$W=( "__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__"; - - # See: &escapeHTML - do { cluck "charset==$_, expecting ISO-8859-1" if $_ ne "ISO-8859-1"; } for CGI::charset(); - CGI::charset("utf-8"); + exit_hook_start(); do { $W->{$_}=0 if !defined $W->{$_}; } for "detect_ent"; do { $W->{$_}=0 if !defined $W->{$_}; } for "detect_js"; @@ -203,50 +190,23 @@ my($class,%args)=@_; select *STDOUT; $|=1; - $W->{"QUERY_STRING"}=$W->{"r"}->args() || ""; - if ($W->{"detect_ent"}) { - if ($W->{"QUERY_STRING"}=~/[&]amp;have_ent/) - { $W->{"have_ent"}=0; } - elsif ($W->{"QUERY_STRING"}=~ /[&]have_ent/) - { $W->{"have_ent"}=1; } - else - { delete $W->{"have_ent"}; } - if (!defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") { - $W->{"head"}.='{"web_hostname"}."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] - ."?".($W->{"QUERY_STRING"} || "detect_ent_glue=1").'&have_ent=detect') - .'" />'."\n"; - } - } - $W->{"QUERY_STRING"}=~s/([&])amp;/$1/g; - $W->{"r"}->args($W->{"QUERY_STRING"}); - # Workaround: &CGI::Vars behaves weird if strings passed both as POST data and in: $QUERY_STRING - 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_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]; - } - $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({ - "_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 $$_; } } @@ -263,20 +223,228 @@ my($class,%args)=@_; $W->{"headers_in"}=$W->{"headers_in_RecordKeys"}; } - $W->{"browser"}=HTTP::BrowserDetect->new($W->{"headers_in"}{"User-Agent"}); + { + local $_=$W->{"r"}->args() || ""; + if ($W->{"detect_ent"}) { + if (/[&]amp;have_ent/) + { $W->{"have_ent"}=0; } + elsif ( /[&]have_ent/) + { $W->{"have_ent"}=1; } + else + { delete $W->{"have_ent"}; } + if (!defined $W->{"have_ent"} && $W->{"r"}->method() eq "GET") { + $W->{"head"}.='{"web_hostname"}."/".($W->{"r"}->uri()=~m#^/*(.*)$#)[0] + ."?".($_ || "detect_ent_glue=1").'&have_ent=detect') + .'" />'."\n"; + } + } + s/([&])amp;/$1/g; + $W->{"r"}->args($_); + } + + $W->{"args"}=URI->new("?".$W->{"r"}->args())->query_form_hash(); + $W->merge_post_args() if $W->{"r"}->method() eq "POST"; + # Prepare '$args' first to (FIXME: Why?) prevent: Not a reference + my $args=$W->{"args"}; + $W->{"args_orig"}=Storable::dclone($args); + + $W->{"browser"}=sub { + # Lazy-evaluation, we may not need the "User-Agent" header at all. + return our $r||=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); + $W->{"have_style"}=sub { + # Lazy-evaluation, we may not need the "User-Agent" header at all. + return our $r||=(!$W->{"browser"}->netscape() || ($W->{"browser"}->major() && $W->{"browser"}->major()>4) ? 1 : 0); + }; } $W->{"have_js"}=($W->{"args"}{"have_js"} ? 1 : 0); if ($W->{"detect_js"} && !$W->{"have_js"}) { - $W->{"head"}.=''."\n"; + # Do not: '."\n"; } do { _args_check(%$_) if $_; } for ($W->{"args_check"}); - return bless $W,$class; + $W->{"_init_done"}=1; + return $W; +} + +sub merge_post_args($) +{ +my($class)=@_; + + my @post_args=$class->read_post_args(); + while (@post_args) { + my $name=shift @post_args; + my $data=shift @post_args; + my $ref=\$W->{"args"}{$name}; + if (!defined $$ref) { $$ref=$data; } + elsif (!ref $$ref) { $$ref=[$$ref,$data]; } + elsif ("ARRAY" eq ref $$ref) { push @$$ref,$data; } + else { + cluck "Ignoring POST argument \"$name\", orig is weird:\n",Dumper($$ref); + } + } + return; +} + +# Do not: use CGI; +# as CGI parsing of POST vs. QUERY_STRING data, multiple-valued keys etc. +# is too dense and causes weird problems, together with mod_perl etc. +sub read_post_args($) +{ +my($class)=@_; + + local $_=$class->http_headers_in_for("Content-type")->content_type(); + return $class->read_multipart_form_data() if $_ eq "multipart/form-data"; + return $class->read_application_x_www_form_urlencoded() if $_ eq "application/x-www-form-urlencoded"; + cluck "Unknown POST data body, ignored: $_"; + return; +} + +sub read_application_x_www_form_urlencoded($) +{ +my($class)=@_; + + my $body=""; + for (;;) { + my $got=$W->{"r"}->read(my($buf),0x1000); + # Do not: cluck "Error reading POST data: $!" if !defined $got; + # as it should be done using: APR::Error exceptions + last if !$got; + $body.=$buf; + } + return URI->new("?".$body)->query_form(); +} + +sub read_multipart_form_data($) +{ +my($class)=@_; + + my $parser=MIME::Parser->new(); + # FIXME: No unlink()s done! + $parser->output_under("/tmp"); + + local *R_FH; + tie *R_FH,$W->{"r"}; + local *FH; + tie *FH,"My::Web::ReadMerged", + join("",map(($_.": ".$W->{"headers_in"}{$_}."\n"),qw( + Content-type + )))."\n", + \*R_FH; + my $body=$parser->parse(\*FH); + cluck "No multipart POST request body?" if !$body->is_multipart(); + + return map(( + $_->head()->mime_attr("content-disposition.name") + => + join("",@{$_->body()}) + ),$body->parts()); + + # TODO: Globalize, make it IO::* compatible, split to the merging part + IO::Scalar. + package My::Web::ReadMerged; + + require Tie::Handle; + require Exporter; + our @ISA=qw(Tie::Handle Exporter); + use Carp qw(cluck confess); + + sub READLINE($) + { + my($self)=@_; + + confess "Slurp not yet implemented" if !defined $/; + # Apache2::RequestIO does not support 'READLINE'! + for (;;) { + if (defined $self->{"data"} && $self->{"data"}=~s{^.*\Q$/\E}{}) { + $self->{"offset"}+=length $&; + return $&; + } + my $fh_orig=$self->{"fh_orig"}; + if (!$fh_orig) { + my $r=$self->{"data"}; + delete $self->{"data"}; + $self->{"offset"}+=length $r if defined $r; + return $r; + } + my $got=read $fh_orig,my($buf),0x1000; + cluck "Error reading POST data: $!" if !defined $got; + delete $self->{"fh_orig"} if !$got; + cluck "INTERNAL: fh_orig should not exist here" if !defined $self->{"data"}; + $self->{"data"}.=$buf; + } + } + + sub TELL($) + { + my($self)=@_; + + return $self->{"offset"}; + } + + sub TIEHANDLE($$$) + { + my($class,$data,$fh_orig)=@_; + + my $self=bless {},$class; + $self->{"data"}=$data; + $self->{"offset"}=0; + $self->{"fh_orig"}=$fh_orig; + return $self; + } +} + +sub cleanup($) +{ +my($apache_request)=@_; + + cluck "CORE::GLOBAL::exit hook not ran" if !$W->{"_exit_done"}; + cluck "packages not finalized" if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}; + cache_finish(); + # Sanity protection. + $W=undef(); + exit_hook_stop(); + 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; +sub exit_hook +{ + cluck "Missing ->init while in exit_hook()" if !$W->{"_init_done"}; + # &footer will call us recursively! + footer() if !$W->{"_exit_done"}++; + return &{$exit_orig}(@_); +} +sub exit_hook_start +{ + do { cluck "exit_hook_start() twice?"; return; } if defined $exit_orig; + $exit_orig=\&CORE::GLOBAL::exit; + # Prevent: Subroutine CORE::GLOBAL::exit redefined + no warnings 'redefine'; + *CORE::GLOBAL::exit=\&exit_hook; +} +sub exit_hook_stop +{ + do { cluck "exit_hook_stop() without exit_hook_start()?"; return; } + if \&exit_hook ne \&CORE::GLOBAL::exit; + do { cluck "INTERNAL: exit_orig uninitialized"; return; } + if !$exit_orig; + # Prevent: Subroutine CORE::GLOBAL::exit redefined + no warnings 'redefine'; + *CORE::GLOBAL::exit=$exit_orig; + $exit_orig=undef(); } # Be aware other parts of code (non-My::Web) will NOT use this function! @@ -292,44 +460,34 @@ 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 escapeHTML($) -{ -my($text)=@_; - - # 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); -} - -# local *FH; -# tie *FH,ref($W),$W; -sub TIEHANDLE($) +sub request_check(;$) { -my($class,$W)=@_; +my($self)=@_; - my $self={}; - $self->{"W"}=$W or confess "Missing W"; - return bless $self,$class; + # Use &eval to prevent: Global $r object is not available. Set:\n\tPerlOptions +GlobalRequest\nin ... + 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 WRITE +# Do not: use CGI; +# as it is too much backward compatible regarding the charset encodings etc. +# and the resulting code is too dense with no additional functionality for the recent content. +sub escapeHTML($) { -my($self,$scalar,$length,$offset)=@_; +my($text)=@_; - Wprint substr($scalar,0,$length); + local $_=$text; + s{&}{&}gso; + s{<}{<}gso; + s{>}{>}gso; + s{"}{"}gso; + return $_; } # /home/user/www/webdir @@ -395,6 +553,7 @@ my($in,%args)=@_; my $uri=in_to_uri_abs($in); if (uri_is_local($uri)) { # Prefer the $uri values over "args_persistent" values. + # &query_form_hash comes from: URI::QueryParam $uri->query_form_hash({ map({ my $key=$_; @@ -479,21 +638,38 @@ 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_packages_used_comments() { - exit 1 if $W->{"footer_passed"}++; # deadlock prevention: - - Wprint vskip if $W->{"footer_delimit"}; + my $packages_used=$packages_used_array{$W->{"__PACKAGE__"}}; + for my $package (@$packages_used) { + my $cvs_id=(eval('$'.$package."::CVS_ID") +# || $package # debug + ); + Wprint ''."\n" if $cvs_id; + } +} - do { Wprint $_ if $_; } for $W->{"footing_delimit"}; +sub footer() +{ + cluck 'Explicit &footer call is deprecated, !_exit_dne' if !$W->{"_exit_done"}; + exit if $W->{"footer_done"}++; # deadlock prevention: + &{$_}() for reverse @{$W->{"footer_sub_push"}}; + if ($W->{"header_only"}) { + $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; + exit; + } + Wprint vskip if $W->{"footer_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=$_; @@ -519,11 +695,17 @@ sub footer (;$) cluck "Class file $file not found; tried: ".join(" ",@tried) if !$ext; } $file.=$ext; + my $viewcvs; + if ((my $file_cvs=$file)=~s{^My/}{}) { + $viewcvs=$W->{"viewcvs_My"}.$file_cvs; + } + else { + $viewcvs=$W->{"viewcvs"}.$file; + } $cvs_id_split[2]="" - .a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $W->{"viewcvs"}))[0]."$file?rev=".$cvs_id_split[2], + .a_href((map({ my $s=$_; $s=~s#/viewcvs/#$&~checkout~/#; $s; } $viewcvs))[0]."?rev=".$cvs_id_split[2], $cvs_id_split[2]); - $cvs_id_split[1]=a_href($W->{"viewcvs"}.$file, - ($package!~/^Apache2::/ ? $package : $cvs_id_split[1])); + $cvs_id_split[1]=a_href($viewcvs,($package!~/^Apache2::/ ? $package : $cvs_id_split[1])); $cvs_id_split[5]=&{$W->{"cvs_id_author_sub"}}($cvs_id_split[5]); } join " ",@cvs_id_split; @@ -532,17 +714,12 @@ sub footer (;$) Wprint "

\n"; } - for my $package (@$packages_used) { - my $cvs_id=(eval('$'.$package."::CVS_ID") -# || $package # debug - ); - Wprint ''."\n" if $cvs_id; - } + footer_packages_used_comments(); do { Wprint $_ if $_; } for $W->{"footing"}; Wprint "\n"; - exit 0; + exit; } # Existing entries are overwritten. @@ -595,7 +772,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; @@ -659,6 +836,8 @@ my($self,$url,$status)=@_; $W->{"r"}->status($status); $W->{"r"}->headers_out()->{"Location"}=$url; $W->{"header_only"}=1; + $W->{"content_type"}=0; + $W->{"charset"}=0; My::Web->heading(); exit; die "NOTREACHED"; @@ -671,22 +850,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; } @@ -730,6 +916,15 @@ my(%args)=@_; return [ map(($args{$_}),@fields) ]; } +# Returns: 'HTTP::Headers' instance. +sub http_headers_in_for($@) +{ +my($self,@headers)=@_; + + # Limit these entries to generate proper 'Vary' header. + return HTTP::Headers->new(map(($_=>$W->{"headers_in"}{$_}),@headers)); +} + # Input: $self is required! # Input: Put the fallback variant as the first one. # Returns: always only scalar! @@ -737,13 +932,6 @@ 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. @@ -751,7 +939,12 @@ 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(%hash)); + $self->http_headers_in_for(qw( + Accept + Accept-Charset + Accept-Encoding + Accept-Language + ))); $best||=$variants->[0][0]; # $variants->[0]{"id"}; &HTTP::Negotiate::choose failed? return $best; } @@ -915,8 +1108,9 @@ sub cache_start() # &Wrequire it here even if it will not be later used; to be stable! Wrequire 'My::Hash::RestrictTo'; my %uri_args_hash=( + "method"=>$W->{"r"}->method(), "uri"=>"http://".$W->{"web_hostname"}."/".$W->{"r"}->uri(), - "args"=>$W->{"args_orig_array"}, + "args"=>$W->{"args_orig"}, ); $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"}}); @@ -944,7 +1138,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,9 +1172,12 @@ 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"}; + # Headers may not be complete in this case; not sure, just trying. + return if $W->{"r"}->connection()->aborted(); + # 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(); @@ -996,7 +1194,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() ? @@ -1010,7 +1214,7 @@ sub cache_finish() delete $Vary{$_}; } %Vary=("*"=>1) if $Vary{"*"}; - $headers_out{"Vary"}=join(", ",sort keys(%Vary)); + $headers_out{"Vary"}=join(", ",sort keys(%Vary)) if keys(%Vary); # $W->{"r"}->set_last_modified() ? $headers_out{"Last-Modified"}=cache_finish_last_modified(); @@ -1034,61 +1238,83 @@ my($class)=@_; if (!$W->{"header_only"}) { header("Content-Style-Type"=>"text/css"); - header("Content-Script-Type"=>"text/javascript"); + # Do not: text/javascript + # as it does not look as registered, at least according to: MIME::Types $VERSION 1.15 + # "application/javascript" so far standardized till 2005-12-08 by: + # http://www.ietf.org/internet-drafts/draft-hoehrmann-script-types-03.txt + header("Content-Script-Type"=>"application/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"; + # Use $W->{"charset"}=0 to disable charset. + $W->{"charset"}="us-ascii" + if !defined $W->{"charset"} && (!defined($W->{"content_type"}) || $W->{"content_type"}); # Workaround bug # https://bugzilla.mozilla.org/show_bug.cgi?id=120556 # of at least # 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 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. - # At least - # Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217 - # prefers "application/xhtml+xml" over "text/html" itself: - # text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 - negotiate_variant( - "id"=>"text/html", - "content-type"=>"text/html", - "qs"=>0.6, - "charset"=>$client_charset, - "lang"=>$W->{"language"}, - ), - negotiate_variant( - "id"=>"application/xhtml+xml", - "content-type"=>"application/xhtml+xml", - "qs"=>0.6, - "charset"=>$client_charset, - "lang"=>$W->{"language"}, - ), - # application/xml ? - # text/xml ? - ]); + if (!defined $W->{"content_type"}) { + # Be _stable_ for "headers_in". + my $accept=$W->{"headers_in"}{"Accept"}; + my $user_agent=$W->{"headers_in"}{"User-Agent"}||""; + $W->{"content_type"}="application/xhtml+xml" + if !$accept && $user_agent=~m{^W3C_Validator/}i; + # Be _stable_: + my $negotiated=$class->Negotiate_choose([ + # Put the fallback variant as the first one. + # Rate both variants the same to prefer "text/html" for undecided clients. + # At least + # Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8b) Gecko/20050217 + # prefers "application/xhtml+xml" over "text/html" itself: + # text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5 + negotiate_variant( + "id"=>"text/html", + "content-type"=>"text/html", + "qs"=>0.6, + (!$W->{"charset"} ? () : "charset"=>$W->{"charset"}), + "lang"=>$W->{"language"}, + ), + negotiate_variant( + "id"=>"application/xhtml+xml", + "content-type"=>"application/xhtml+xml", + "qs"=>0.6, + (!$W->{"charset"} ? () : "charset"=>$W->{"charset"}), + "lang"=>$W->{"language"}, + ), + # application/xml ? + # text/xml ? + ]); + $W->{"content_type"}=$negotiated if !defined $W->{"content_type"}; + } # 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"); + my $type; + if ($W->{"content_type"}) { + $type=MIME::Types->new()->type($W->{"content_type"}); + cluck "MIME::Types type '".$W->{"content_type"}."' not known" if !$type; + } + cluck "charset='".$W->{"charset"}."' does not match content-type='".$W->{"content_type"}."'" + if ($W->{"charset"} ? 1 : 0) != (!$type ? 0 : $type->isAscii()); + $W->{"r"}->content_type($W->{"content_type"}.(!$W->{"charset"} ? "" : "; charset=".$W->{"charset"})) + if $W->{"content_type"}; 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"}++; + return if $W->{"heading_done"}; + Wprint '{"charset"}.'"?>'."\n" + if (!$W->{"header_only"} || $W->{"header_only"} eq "xml") && (0 + || $W->{"content_type"}=~m{^application/\w+[+]xml$} + || $W->{"content_type"} eq "text/vnd.wap.wml"); + return if $W->{"header_only"}; + # Split 'heading_done' for the proper handling of: /project/Rel.pm + $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"} || ()))); @@ -1100,14 +1326,20 @@ 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 } if ($W->{"css_inherit"}) { + # Do not: HERE } }