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
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 $