/[pub]/suikawiki/script/lib/SuikaWiki/Output/CGICarp.pm
Suika

Contents of /suikawiki/script/lib/SuikaWiki/Output/CGICarp.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations) (download)
Fri Jan 16 08:03:39 2004 UTC (21 years, 6 months ago) by wakaba
Branch: MAIN
Changes since 1.2: +3 -2 lines
Downgrade module support & {-handle} option support

1 wakaba 1.2
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.26)
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.26
23     use strict;
24 wakaba 1.3 our $VERSION = do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
25 wakaba 1.2 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 wakaba 1.3
48 wakaba 1.2 our $CUSTOM_MSG;
49     sub fatalsToBrowser {
50     my($msg) = @_;
51     $msg=~s/&/&/g;
52     $msg=~s/>/>/g;
53     $msg=~s/</&lt;/g;
54     $msg=~s/\"/&quot;/g;
55     my($wm) = $main::ENV{SERVER_ADMIN} ?
56     qq[the webmaster &lt;<a href="mailto:$main::ENV{SERVER_ADMIN}">$main::ENV{SERVER_ADMIN}</a>&gt;] :
57     "this site's webmaster";
58     my ($outer_message) = <<END;
59     For help, please send mail to $wm, giving this error message
60     and the time and date of the error.
61     END
62     ;
63     my $mod_perl = exists $main::ENV{MOD_PERL};
64     unless ($mod_perl) {
65     print STDOUT "Status: @{[$SuikaWiki::Output::CGICarp::CUSTOM_STATUS_CODE+0]} $SuikaWiki::Output::CGICarp::CUSTOM_REASON_TEXT\n";
66     print STDOUT "Content-type: text/html; charset=iso-8859-1\n\n";
67     }
68    
69     warningsToBrowser(1); # emit warnings before dying
70    
71     if ($CUSTOM_MSG) {
72     if (ref($CUSTOM_MSG) eq 'CODE') {
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     print STDOUT $mess;
117     }
118     }
119    
120     =head1 EXAMPLE
121    
122     use CGI::Carp qw/fatalsToBrowser/;
123     require SuikaWiki::Output::CGICarp;
124    
125     die 'Something wrong';
126    
127     =head1 LICENSE
128    
129     Copyright 2003 Wakaba <w@suika.fam.cx>
130    
131     This program is free software; you can redistribute it and/or
132     modify it under the same terms as Perl itself.
133    
134     =cut
135    
136 wakaba 1.3 1; # $Date: 2003/10/18 07:08:34 $

admin@suikawiki.org
ViewVC Help
Powered by ViewVC 1.1.24