From: short <> Date: Fri, 23 Sep 2005 03:31:00 +0000 (+0000) Subject: Many fixes, incompatible changes, improvements... X-Git-Url: http://git.jankratochvil.net/?p=MyWeb.git;a=commitdiff_plain;h=a20ecc379dc3b96fc5646b3915022a9ffa399d9b Many fixes, incompatible changes, improvements... --- diff --git a/Web.pm b/Web.pm index 0419bc0..ad685e6 100644 --- a/Web.pm +++ b/Web.pm @@ -143,11 +143,15 @@ my($class,%args)=@_; Wuse 'WebConfig'; Wrequire 'My::Hash'; - $W=My::Hash->new({ + # $W={} can get somehow created very easily. + cluck "W not empty:\n".Dumper($W) if keys(%$W); + $W=bless My::Hash->new({}),$class; + $W=My::Hash->new($W,"My::Hash::Sub","My::Hash::Push"); + %$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. @@ -266,18 +270,20 @@ my($class,%args)=@_; do { _args_check(%$_) if $_; } for ($W->{"args_check"}); - return bless $W,$class; + $W->{"_init_done"}=1; + return $W; } sub cleanup($) { my($apache_request)=@_; - cluck "CORE::GLOBAL::exit hook not ran" if !$W->{"_exit_ran"}; + 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; } @@ -286,9 +292,10 @@ my($apache_request)=@_; my $exit_orig; sub exit_hook { - # &footer will call us recursively! - footer() if !$W->{"_exit_ran"}++; - return &{$exit_orig}(@_); + 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 { @@ -303,6 +310,8 @@ sub exit_hook_stop do { cluck "exit_hook_stop() without exit_hook_start()?"; return; } if \&exit_hook ne \&CORE::GLOBAL::exit; cluck "INTERNAL: exit_orig uninitialized" if !$exit_orig; + # Prevent: Subroutine CORE::GLOBAL::exit redefined + no warnings 'redefine'; *CORE::GLOBAL::exit=$exit_orig; $exit_orig=undef(); } @@ -506,9 +515,8 @@ my($msg)=@_; sub footer() { - exit_hook_stop(); - cluck 'Explicit &footer call is deprecated' if !$W->{"_exit_ran"}; - exit if $W->{"footer_passed"}++; # deadlock prevention: + cluck 'Explicit &footer call is deprecated, !_exit_dne' if !$W->{"_exit_done"}; + exit if $W->{"footer_done"}++; # deadlock prevention: if ($W->{"header_only"}) { $packages_used_hash{$W->{"__PACKAGE__"}}{"_done"}=1; exit; @@ -687,6 +695,7 @@ my($self,$url,$status)=@_; $W->{"r"}->status($status); $W->{"r"}->headers_out()->{"Location"}=$url; $W->{"header_only"}=1; + $W->{"content_type"}=0; My::Web->heading(); exit; die "NOTREACHED"; @@ -1083,20 +1092,18 @@ my($class)=@_; # TODO: Support also: private header("Cache-Control"=>"public"); # HTTP/1.1 - # Use $W->{"force_charset"}=0 to disable charset. - my $client_charset=$W->{"force_charset"}; - $client_charset="us-ascii" if !defined $client_charset; + # 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=$W->{"content_type"}; # http://validator.w3.org/ does not send ANY "Accept" headers! - $mime="application/xhtml+xml" if !$mime + $W->{"content_type"}="application/xhtml+xml" if !defined $W->{"content_type"} && !$W->{"headers_in"}{"Accept"} && ($W->{"headers_in"}{"User-Agent"}||"")=~m{^W3C_Validator/}i; - $mime or $mime=$class->Negotiate_choose([ + defined($W->{"content_type"}) or $W->{"content_type"}=$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 @@ -1107,14 +1114,14 @@ my($class)=@_; "id"=>"text/html", "content-type"=>"text/html", "qs"=>0.6, - "charset"=>$client_charset, + (!$W->{"charset"} ? () : "charset"=>$W->{"charset"}), "lang"=>$W->{"language"}, ), negotiate_variant( "id"=>"application/xhtml+xml", "content-type"=>"application/xhtml+xml", "qs"=>0.6, - "charset"=>$client_charset, + (!$W->{"charset"} ? () : "charset"=>$W->{"charset"}), "lang"=>$W->{"language"}, ), # application/xml ? @@ -1122,17 +1129,22 @@ my($class)=@_; ]); # 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. - my $type=MIME::Types->new()->type($mime) if $client_charset; - cluck "MIME::Types type $mime not known" if $client_charset && !$type; - $client_charset=undef() if $type && !$type->isAscii(); - $W->{"r"}->content_type($mime.(!$client_charset ? "" : "; 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(); # 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 (!$W->{"header_only"} || $W->{"header_only"} eq "xml") && $mime=~m{^application/\w+[+]xml$}; + Wprint '{"charset"}.'"?>'."\n" + if (!$W->{"header_only"} || $W->{"header_only"} eq "xml") && $W->{"content_type"}=~m{^application/\w+[+]xml$}; return if $W->{"header_only"}; # Split 'heading_done' for the proper handling of: /project/Rel.pm $W->{"heading_done"}++;