X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=blobdiff_plain;f=Web.pm;h=456e7c8bcfd721d12166e2aa86d985469d83e829;hp=c6a0452c2f92f58c28b89d88af03647534638ea8;hb=1ee642491d049abd3ee7324f395940f1650436bf;hpb=302a5dd3ae3231811ca76abee9d7f6c19a803fec diff --git a/Web.pm b/Web.pm index c6a0452..456e7c8 100644 --- a/Web.pm +++ b/Web.pm @@ -46,9 +46,11 @@ BEGIN $file.=".pm"; my $who=$W->{"__PACKAGE__"}; $who||="__My::Web" if $W->{"__My::Web_init"}; - my $aref=($W->{"packages_used"}{$who}||=[]); - push @$aref,$class - if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. + if ($who) { + my $aref=($W->{"packages_used"}{$who}||=[]); + push @$aref,$class + if !{ map(($_=>1),@$aref) }->{$class}; # Prevent duplicated entries. + } CORE::require $file; 1; # Otherwise 'require' would already file above. } @@ -85,7 +87,6 @@ use URI::QueryParam; #our $W; # $W->{"title"} # $W->{"head"} - # $W->{"head_css"} # $W->{"force_charset"} # $W->{"heading_done"} # $W->{"footer_passed"} @@ -120,7 +121,8 @@ my($class,%args)=@_; 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 ("head_css"); + do { $W->{$_}="" if !defined $W->{$_}; } for ("body_attr"); + do { $W->{$_}="en-US" if !defined $W->{$_}; } for ("language"); my $footer_any=0; for (qw(footer_mailme footer_ids)) { @@ -428,11 +430,15 @@ my($url,%args)=@_; $url=top_dir($url,%args) if $url=~m#^/# || $args{"abs"}; my $uri=URI->new($url); - for my $key (keys(%{$W->{"args_persistent"}})) { - my $val=$W->{"args"}{$key}; - next if !defined $val; - $uri->query_param_append($key=>$val); - } + # Prefer the $uri values over "args_persistent" values. + $uri->query_form_hash({ + map({ + my $key=$_; + my $val=$W->{"args"}{$key}; + (!defined $val ? () : ($key=>$val)); + } keys(%{$W->{"args_persistent"}})), + %{$uri->query_form_hash()}, + }); $url="".$uri; return $url; @@ -554,9 +560,28 @@ my(%args)=@_; return [ map(($args{$_}),@fields) ]; } +# Input: $self is required! +# Input: Put the fallback variant as the first one. +# Returns: always only scalar! +sub Negotiate_choose($$) +{ +my($self,$variants)=@_; + + my $best=HTTP::Negotiate::choose($variants, + # Do not: $W->{"r"} + # to prevent: Can't locate object method "scan" via package "Apache::RequestRec" at HTTP/Negotiate.pm line 84. + # Do not: $W->{"r"}->headers_in() + # 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()})); + $best||=$variants->[0]{"id"}; # &HTTP::Negotiate::choose failed? + return $best; +} + my @img_variants=( - { "id"=>"png","qs"=>1.0,"content-type"=>"image/png" }, - { "id"=>"gif","qs"=>0.9,"content-type"=>"image/gif" }, + { "id"=>"png","qs"=>0.9,"content-type"=>"image/png" }, + { "id"=>"gif","qs"=>0.7,"content-type"=>"image/gif" }, ); my $img_variants_re='[.](?:'.join('|',"jpeg",map(($_->{"id"}),@img_variants)).')$'; @@ -597,10 +622,7 @@ my($file_base)=@_; "size"=>(stat $file)[7], ); } - # Do not: ,$W->{"r"}); - # but should we provide somehow either 'HTTP::Headers' or 'HTTP::Request' ? - my $ext=HTTP::Negotiate::choose(\@nego_variants); - $ext||=$img_variants[0]->{"id"}; # &HTTP::Negotiate::choose failed? + my $ext=__PACKAGE__->Negotiate_choose(\@nego_variants); return $file_base_uri.".".$ext if !wantarray(); return ($file_base_uri.".".$ext,$file_base_disk.".".$ext); @@ -696,59 +718,63 @@ my($class)=@_; 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"}->header_out($key,$val); } - if (!$W->{"header_only"}) { - $W->{"r"}->send_http_header("text/html; charset=$client_charset"); # "Content-type"; do not use header() - } - 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"}++; + my $lang=($W->{"language"}||"en-US"); + # 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=$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"=>$lang, + ), + negotiate_variant( + "id"=>"application/xhtml+xml", + "content-type"=>"application/xhtml+xml", + "qs"=>0.6, + "charset"=>$client_charset, + "lang"=>$lang, + ), + # application/xml ? + # text/xml ? + ]); + $W->{"r"}->send_http_header("$mime; charset=$client_charset"); # "Content-type"; do not use header() if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn Wprint ''."\n"; } Wprint ''."\n"; - Wprint ''."\n"; + Wprint ''."\n"; my $title=$W->{"title_prefix"}.join("",map({ ': '.$_; } ($W->{"title"} || ()))); $title=~s#<[^>]*>##g; Wprint ""; Wprint "$title\n"; - if ($W->{"have_css"}) { - Wprint <<'HERE'; -\n"; } - Wprint ''."\n"; Wprint $W->{"head"}; for my $type (qw(prev next index contents start up)) { @@ -757,7 +783,7 @@ HERE Wprint "{"browser"}->netscape() && (!$W->{"browser"}->major() || $W->{"browser"}->major()<=4); - do { &{$_}($W) if $_; } for $W->{"body_attr_sub"}; + Wprint $W->{"body_attr"}; Wprint ">\n"; do { &{$_}() if $_; } for ($W->{"heading"});