Fixed &fatal to always prepend the error with heading.

[MyWeb.git] / Web.pm

diff --git a/Web.pm b/Web.pm
index 2dd7747..c4dd46d 100644 (file)
--- a/Web.pm
+++ b/Web.pm
@@ -27,8 +27,8 @@ use Exporter;
 sub Wrequire ($);
 sub Wuse ($@);
 our $W;
-our @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img &centerimg &rightimg $W &top_dir &top_dir_disk &Wprint);
-our @ISA=qw(Exporter);
+our @EXPORT=qw(&Wrequire &Wuse &a_href &a_href_cz &vskip &img &centerimg &rightimg $W &top_dir &top_dir_disk &Wprint &input_hidden_persistents);
+our @ISA=qw(Exporter Tie::Handle);
 
 BEGIN
 {
@@ -76,6 +76,10 @@ require HTTP::Negotiate;
 my $have_Geo_IP; BEGIN { $have_Geo_IP=eval { require Geo::IP; 1; }; }
 use ModPerl::Util qw(exit);
 use POSIX qw(strftime);
+use Tie::Handle;
+use Apache::Const qw(HTTP_MOVED_TEMPORARILY);
+use URI;
+use URI::QueryParam;
 
 
 #our $W;
@@ -110,7 +114,6 @@ my($class,%args)=@_;
        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 ("heading");
        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_mailme");
@@ -171,14 +174,32 @@ my($class,%args)=@_;
 
        $ENV{"HOSTNAME"}||=&{$W->{"web_hostname_sub"}}();
 
-       return $W;
+       return bless $W,$class;
 }
 
 sub Wprint($)
 {
 my($text)=@_;
 
-       $W->{"r"}->print($text);
+       $W->{"r"}->puts($text);
+}
+
+# local *FH;
+# tie *FH,ref($W),$W;
+sub TIEHANDLE($)
+{
+my($class,$W)=@_;
+
+       my $self={};
+       $self->{"W"}=$W or confess "Missing W";
+       return bless $self,$class;
+}
+
+sub WRITE
+{
+my($self,$scalar,$length,$offset)=@_;
+
+       Wprint substr($scalar,0,$length);
 }
 
 sub top_dir_disk ()
@@ -187,12 +208,13 @@ sub top_dir_disk ()
        return $INC[0]; # fallback
 }
 
-sub top_dir (;$)
+# $args{"abs"}
+sub top_dir (;$%)
 {
-my($in)=@_;
+my($in,%args)=@_;
 
        if (my $uri=$W->{"r"}->unparsed_uri()) {
-               if ($W->{"args"}{"Wabs"}) {
+               if ($W->{"args"}{"Wabs"} || $args{"abs"}) {
                        # FIXME: $in may not be defined here!
                        # to prevent: Use of uninitialized value in ...
                        if ($in=~m#^/#) {
@@ -265,6 +287,8 @@ my($msg)=@_;
        $msg="UNKNOWN" if !$msg;
 
        $W->{"indexme"}=0;      # For the case no heading was sent yet.
+       $W->{"heading_done"}=0; # for the case of already sent {"header_only"}==1
+       $W->{"header_only"}=0;  # assurance for &heading
        My::Web->heading();
        Wprint "\n".vskip("3ex")."<hr /><h1 class=\"error\">FATAL ERROR: $msg!</h1>\n"
                        ."<p>You can report this problem's details to"
@@ -278,9 +302,7 @@ sub footer (;$)
 
        Wprint vskip if $W->{"footer_delimit"};
 
-       if ($W->{"heading"}) {
-               do { &{$_}() if $_; } for ($W->{"footing_delimit"});
-               }
+       do { &{$_}() if $_; } for ($W->{"footing_delimit"});
 
        Wprint "<hr />\n" if $W->{"footer"};
 
@@ -290,6 +312,7 @@ sub footer (;$)
                                ."this.elements['msghtml'].value='';"
                                ."this.submit();"
                                .'">'."\n";
+                       Wprint input_hidden_persistents()."\n";
                        Wprint '<p align="right">'."\n";
                                Wprint '<input name="msgscript" type="hidden" />'."\n";
                                Wprint '<input name="msghtml" type="text" size="32" alt="Message" />'."\n";
@@ -351,9 +374,7 @@ sub footer (;$)
                Wprint '<!-- '.$package.' - $'.$cvs_id.'$ -->'."\n" if $cvs_id;
                }
 
-       if ($W->{"heading"}) {
-               do { &{$_}() if $_; } for ($W->{"footing"});
-               }
+       do { &{$_}() if $_; } for ($W->{"footing"});
 
        Wprint "</body></html>\n";
        exit(0);
@@ -394,6 +415,24 @@ my($url)=@_;
        return $url!~m#^[a-z]+://#;
 }
 
+sub url_out($%)
+{
+my($url,%args)=@_;
+
+       return if !url_is_local $url;
+       $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);
+               }
+       $url="".$uri;
+
+       return $url;
+}
+
 sub a_href ($;$%)
 {
 my($url,$contents,%args)=@_;
@@ -407,7 +446,7 @@ my($url,$contents,%args)=@_;
        $contents=~s#<a\b[^>]*>##gi;
        $contents=~s#</a>##gi;
 
-       $url=top_dir($url) if url_is_local $url && $url=~m#^/#;
+       $url=url_out($url);
 
        my $r='<a href="';
        my $urlent=CGI::escapeHTML($url);
@@ -435,6 +474,32 @@ my($url,$contents,%args)=@_;
        return $r;
 }
 
+sub input_hidden_persistents()
+{
+       return join("",map({
+               my $key=$_;
+               my $val=$W->{"args"}{$key};
+               (!defined $val ? () : '<input type="hidden"'
+                               .' name="'.CGI::escapeHTML($key).'"'
+                               .' value="'.CGI::escapeHTML($val).'"'
+                               .' />'."\n");
+               } (keys(%{$W->{"args_persistent"}}))));
+}
+
+sub http_moved($$;$)
+{
+my($self,$url,$status)=@_;
+
+       $url=url_out($url,"abs"=>1);
+       $status||=Apache::HTTP_MOVED_TEMPORARILY;
+       $W->{"r"}->status($status);
+       $W->{"r"}->header_out("Location"=>$url);
+       $W->{"header_only"}=1;
+       My::Web->heading();
+       exit;
+       die "NOTREACHED";
+}
+
 sub remote_ip ()
 {
        # Do not: PerlModule                 Apache::ForwardedFor
@@ -622,8 +687,6 @@ sub heading ()
 {
 my($class)=@_;
 
-       return if $W->{"heading_passed"}++;
-
        # $ENV{"CLIENT_CHARSET"} ignored (mod_czech support dropped!)
        my $client_charset=$W->{"force_charset"} || "us-ascii";
        header("Content-Style-Type"=>"text/css");
@@ -633,10 +696,13 @@ my($class)=@_;
        while (my($key,$val)=each(%{$W->{"headers"}})) {
                $W->{"r"}->header_out($key,$val);
                }
-       $W->{"r"}->send_http_header("text/html; charset=$client_charset");      # "Content-type"; do not use header()
+       if (!$W->{"header_only"}) {
+               $W->{"r"}->send_http_header("text/html; charset=$client_charset");      # "Content-type"; do not use header()
+               }
 
        return if $W->{"heading_done"}++;
        exit if $W->{"r"}->header_only();
+       return if $W->{"header_only"};
 
        if (1) { # || !$msie_major || $msie_major>=4) # TODO:dyn
                Wprint '<?xml version="1.0" encoding="'.$client_charset.'"?>'."\n";
@@ -687,9 +753,7 @@ HERE
        do { &{$_}($W) if $_; } for $W->{"body_attr_sub"};
        Wprint ">\n";
 
-       if ($W->{"heading"}) {
-               do { &{$_}() if $_; } for ($W->{"heading"});
-               }
+       do { &{$_}() if $_; } for ($W->{"heading"});
 }
 
 BEGIN {