Message/CGI/Carp.pm


=head1 NAME

SuikaWiki::Output::CGICarp --- SuikaWiki : CGI::Carp modification to
return 500 status code

=head1 DESCRIPTION

At the time of writing, latest version of CGI::Carp (1.27)
does not output error dying message with 500 (Internal Server Error)
HTTP status code unless it is working on mod_perl.

This module overrides some of CGI::Carp functions to return 500 status
code.  Users of this module should take attention whether later revision
of CGI::Carp provides improved version of CGI outputing methods.

This module is part of SuikaWiki.

=cut

package SuikaWiki::Output::CGICarp;
require CGI::Carp; # 1.27
use strict;
our $VERSION = do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
our $CUSTOM_REASON_TEXT = 'Internal CGI Script Error';
our $CUSTOM_STATUS_CODE = 500;

=head1 OPTIONS

=over 4

=item $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT (Default : Internal CGI Script Error)

Short description of error status.  This string should contains only
printable ASCII characters (including SPACE) for interoperability
and line break characters (CR and LF) MUST NOT be used.

=item $SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE (Default : 500)

Three digit status code defined by HTTP specifications.

=back

=cut

package CGI::Carp;
our $CUSTOM_MSG;
sub fatalsToBrowser {
  my($msg) = @_;
  $msg=~s/&/&amp;/g;
  $msg=~s/>/&gt;/g;
  $msg=~s/</&lt;/g;
  $msg=~s/\"/&quot;/g;
  my($wm) = $main::ENV{SERVER_ADMIN} ? 
    qq[the webmaster &lt;<a href="mailto:$main::ENV{SERVER_ADMIN}">$main::ENV{SERVER_ADMIN}</a>&gt;] :
      "this site's webmaster";
  my ($outer_message) = <<END;
For help, please send mail to $wm, giving this error message 
and the time and date of the error.
END
  ;
  my $mod_perl = exists $main::ENV{MOD_PERL};

  warningsToBrowser(1);    # emit warnings before dying

  if ($CUSTOM_MSG) {
    if (ref($CUSTOM_MSG) eq 'CODE') {
      my $bytes_written = eval{tell STDOUT};
      unless (defined $bytes_written && $bytes_written > 0) {
        print STDOUT "Status: @{[$SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE+0]} $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT\n";
        print STDOUT "Content-type: text/html; charset=iso-8859-1\n\n";
      }
      &$CUSTOM_MSG($msg); # nicer to perl 5.003 users
      return;
    } else {
      $outer_message = $CUSTOM_MSG;
    }
  }

  my $mess = <<END;
<h1>Software error:</h1>
<pre>$msg</pre>
<p>
$outer_message
</p>
END
  ;

  if ($mod_perl) {
    require mod_perl;
    if ($mod_perl::VERSION >= 1.99) {
      $mod_perl = 2;
      require Apache::RequestRec;
      require Apache::RequestIO;
      require Apache::RequestUtil;
      require APR::Pool;
      require ModPerl::Util;
      require Apache::Response;
    }
    my $r = Apache->request;
    # If bytes have already been sent, then
    # we print the message out directly.
    # Otherwise we make a custom error
    # handler to produce the doc for us.
    if ($r->bytes_sent) {
      $r->print($mess);
      $mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
    } else {
      # MSIE won't display a custom 500 response unless it is >512 bytes!
      if ($main::ENV{HTTP_USER_AGENT} =~ /MSIE/) {
        $mess = "<!-- " . (' ' x 513) . " -->\n$mess";
      }
      $r->custom_response($SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE+0,$mess);
    }
  } else {
    my $bytes_written = eval{tell STDOUT};
    if (defined $bytes_written && $bytes_written > 0) {
      print STDOUT $mess;
    } else {
      print STDOUT "Status: @{[$SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE+0]} $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT\n";
      print STDOUT "Content-type: text/html; charset=iso-8859-1\n\n";
      print STDOUT $mess;
    }
  }
}

=head1 EXAMPLE

  use CGI::Carp qw/fatalsToBrowser/;
  require SuikaWiki::Output::CGICarp;
  
  die 'Something wrong';

=head1 LICENSE

Copyright 2003-2004 Wakaba <w@suika.fam.cx>

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut

1; # $Date: 2004/01/17 09:18:38 $
1	wakaba	1.1
2			=head1 NAME
3
4			SuikaWiki::Output::CGICarp --- SuikaWiki : CGI::Carp modification to
5			return 500 status code
6
7			=head1 DESCRIPTION
8
9			At the time of writing, latest version of CGI::Carp (1.27)
10			does not output error dying message with 500 (Internal Server Error)
11			HTTP status code unless it is working on mod_perl.
12
13			This module overrides some of CGI::Carp functions to return 500 status
14			code. Users of this module should take attention whether later revision
15			of CGI::Carp provides improved version of CGI outputing methods.
16
17			This module is part of SuikaWiki.
18
19			=cut
20
21			package SuikaWiki::Output::CGICarp;
22			require CGI::Carp; # 1.27
23			use strict;
24			our $VERSION = do{my @r=(q$Revision: 1.4 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
25			our $CUSTOM_REASON_TEXT = 'Internal CGI Script Error';
26			our $CUSTOM_STATUS_CODE = 500;
27
28			=head1 OPTIONS
29
30			=over 4
31
32			=item $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT (Default : Internal CGI Script Error)
33
34			Short description of error status. This string should contains only
35			printable ASCII characters (including SPACE) for interoperability
36			and line break characters (CR and LF) MUST NOT be used.
37
38			=item $SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE (Default : 500)
39
40			Three digit status code defined by HTTP specifications.
41
42			=back
43
44			=cut
45
46			package CGI::Carp;
47			our $CUSTOM_MSG;
48			sub fatalsToBrowser {
49			my($msg) = @_;
50			$msg=~s/&/&/g;
51			$msg=~s/>/>/g;
52			$msg=~s/</</g;
53			$msg=~s/\"/"/g;
54			my($wm) = $main::ENV{SERVER_ADMIN} ?
55			qq[the webmaster <<a href="mailto:$main::ENV{SERVER_ADMIN}">$main::ENV{SERVER_ADMIN}</a>>] :
56			"this site's webmaster";
57			my ($outer_message) = <<END;
58			For help, please send mail to $wm, giving this error message
59			and the time and date of the error.
60			END
61			;
62			my $mod_perl = exists $main::ENV{MOD_PERL};
63
64			warningsToBrowser(1); # emit warnings before dying
65
66			if ($CUSTOM_MSG) {
67			if (ref($CUSTOM_MSG) eq 'CODE') {
68			my $bytes_written = eval{tell STDOUT};
69			unless (defined $bytes_written && $bytes_written > 0) {
70			print STDOUT "Status: @{[$SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE+0]} $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT\n";
71			print STDOUT "Content-type: text/html; charset=iso-8859-1\n\n";
72			}
73			&$CUSTOM_MSG($msg); # nicer to perl 5.003 users
74			return;
75			} else {
76			$outer_message = $CUSTOM_MSG;
77			}
78			}
79
80			my $mess = <<END;
81			<h1>Software error:</h1>
82			<pre>$msg</pre>
83			<p>
84			$outer_message
85			</p>
86			END
87			;
88
89			if ($mod_perl) {
90			require mod_perl;
91			if ($mod_perl::VERSION >= 1.99) {
92			$mod_perl = 2;
93			require Apache::RequestRec;
94			require Apache::RequestIO;
95			require Apache::RequestUtil;
96			require APR::Pool;
97			require ModPerl::Util;
98			require Apache::Response;
99			}
100			my $r = Apache->request;
101			# If bytes have already been sent, then
102			# we print the message out directly.
103			# Otherwise we make a custom error
104			# handler to produce the doc for us.
105			if ($r->bytes_sent) {
106			$r->print($mess);
107			$mod_perl == 2 ? ModPerl::Util::exit(0) : $r->exit;
108			} else {
109			# MSIE won't display a custom 500 response unless it is >512 bytes!
110			if ($main::ENV{HTTP_USER_AGENT} =~ /MSIE/) {
111			$mess = "<!-- " . (' ' x 513) . " -->\n$mess";
112			}
113			$r->custom_response($SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE+0,$mess);
114			}
115			} else {
116			my $bytes_written = eval{tell STDOUT};
117			if (defined $bytes_written && $bytes_written > 0) {
118			print STDOUT $mess;
119			} else {
120			print STDOUT "Status: @{[$SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE+0]} $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT\n";
121			print STDOUT "Content-type: text/html; charset=iso-8859-1\n\n";
122			print STDOUT $mess;
123			}
124			}
125			}
126
127			=head1 EXAMPLE
128
129			use CGI::Carp qw/fatalsToBrowser/;
130			require SuikaWiki::Output::CGICarp;
131
132			die 'Something wrong';
133
134			=head1 LICENSE
135
136			Copyright 2003-2004 Wakaba <w@suika.fam.cx>
137
138			This program is free software; you can redistribute it and/or
139			modify it under the same terms as Perl itself.
140
141			=cut
142
143			1; # $Date: 2004/01/17 09:18:38 $