Many fixes, incompatible changes, improvements...

diff --git a/Web.pm b/Web.pm
index 0419bc0..ad685e6 100644 (file)
--- a/Web.pm
+++ b/Web.pm
@@ -143,11 +143,15 @@ my($class,%args)=@_;
        Wuse 'WebConfig';
        Wrequire 'My::Hash';
 
        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
                "__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.
 
        # {"__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"});
 
 
        do { _args_check(%$_) if $_; } for ($W->{"args_check"});
 

-       return bless $W,$class;
+       $W->{"_init_done"}=1;
+       return $W;

 }
 
 sub cleanup($)
 {
 my($apache_request)=@_;
 
 }
 
 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();
        cluck "packages not finalized" if !$packages_used_hash{$W->{"__PACKAGE__"}}{"_done"};
        cache_finish();
        # Sanity protection.
        $W=undef();

+       exit_hook_stop();

        return OK;
 }
 
        return OK;
 }
 


@@ -286,9 +292,10 @@ my($apache_request)=@_;
 my $exit_orig;
 sub exit_hook
 {
 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
 {
 }
 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;
        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();
 }
        *CORE::GLOBAL::exit=$exit_orig;
        $exit_orig=undef();
 }


@@ -506,9 +515,8 @@ my($msg)=@_;
 
 sub footer()
 {
 
 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;
        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->{"r"}->status($status);
        $W->{"r"}->headers_out()->{"Location"}=$url;
        $W->{"header_only"}=1;

+       $W->{"content_type"}=0;

        My::Web->heading();
        exit;
        die "NOTREACHED";
        My::Web->heading();
        exit;
        die "NOTREACHED";


@@ -1083,20 +1092,18 @@ my($class)=@_;
        # TODO: Support also: private
        header("Cache-Control"=>"public");      # HTTP/1.1
 
        # 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
 
        # 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!
        # 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;
                        && !$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
                        # 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,
                                        "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,
                                        "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 ?
                                        "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.
                        ]);
        # 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"};
 
        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 '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n"
-                       if (!$W->{"header_only"} || $W->{"header_only"} eq "xml") && $mime=~m{^application/\w+[+]xml$};
+       Wprint '<?xml version="1.0" encoding="'.$W->{"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"}++;
        return if $W->{"header_only"};
        # Split 'heading_done' for the proper handling of: /project/Rel.pm
        $W->{"heading_done"}++;