| 1 |
|
| 2 |
=head1 NAME |
| 3 |
|
| 4 |
Message::Field::Status --- "Status:" CGI header field |
| 5 |
|
| 6 |
=cut |
| 7 |
|
| 8 |
package Message::Field::Status; |
| 9 |
use strict; |
| 10 |
use vars qw(%DEFAULT @ISA $REASON %REG $VERSION); |
| 11 |
$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r}; |
| 12 |
require Message::Field::Structured; |
| 13 |
push @ISA, qw(Message::Field::Structured); |
| 14 |
|
| 15 |
*REG = \%Message::Util::REG; |
| 16 |
|
| 17 |
## Initialize of this class -- called by constructors |
| 18 |
%DEFAULT = ( |
| 19 |
-_MEMBERS => [qw|reason_phrase _charset|], |
| 20 |
-_METHODS => [qw|reason_phrase status_code value|], |
| 21 |
-encoding_after_encode => 'iso-8859-1', |
| 22 |
-encoding_before_decode => 'iso-8859-1', |
| 23 |
#field_param_name |
| 24 |
#field_name |
| 25 |
#field_ns |
| 26 |
#format |
| 27 |
#hook_encode_string |
| 28 |
#hook_decode_string |
| 29 |
#parse_all |
| 30 |
-reason_default_set => 'http_1_1_rfc2616', |
| 31 |
-reason_unsafe_rule => qr/[^\x20-\x7E]/, |
| 32 |
-value_pattern => '%03d %s', |
| 33 |
); |
| 34 |
|
| 35 |
%{ $REASON->{common} } = grep {length} split /[\t\x0D\x0A]+/, q( |
| 36 |
200 OK |
| 37 |
201 Created |
| 38 |
202 Accepted |
| 39 |
204 No Content |
| 40 |
301 Moved Permanently |
| 41 |
304 Not Modified |
| 42 |
400 Bad Request |
| 43 |
401 Unauthorized |
| 44 |
403 Forbidden |
| 45 |
404 Not Found |
| 46 |
500 Internal Server Error |
| 47 |
501 Not Implemented |
| 48 |
502 Bad Gateway |
| 49 |
503 Service Unavailable |
| 50 |
|
| 51 |
100 Continue |
| 52 |
101 Switching Protocols |
| 53 |
203 Non-Authoritative Information |
| 54 |
205 Reset Content |
| 55 |
206 Partial Content |
| 56 |
300 Multiple Choices |
| 57 |
303 See Other |
| 58 |
305 Use Proxy |
| 59 |
307 Temporary Redirect |
| 60 |
402 Payment Required |
| 61 |
405 Method Not Allowed |
| 62 |
406 Not Acceptable |
| 63 |
407 Proxy Authentication Required |
| 64 |
408 Request Time-out |
| 65 |
409 Conflict |
| 66 |
410 Gone |
| 67 |
411 Length Required |
| 68 |
412 Precondition Failed |
| 69 |
413 Request Entity Too Large |
| 70 |
414 Request-URI Too Large |
| 71 |
415 Unsupported Media Type |
| 72 |
416 Requested range not satisfiable |
| 73 |
417 Expectation Failed |
| 74 |
504 Gateway Time-out |
| 75 |
505 HTTP Version not supported |
| 76 |
); |
| 77 |
|
| 78 |
$REASON->{http_1_0} = {%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]+/, q( |
| 79 |
302 Moved Temporarily |
| 80 |
)}; |
| 81 |
$REASON->{http_1_1_rfc2068} = {%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]+/, q( |
| 82 |
302 Moved Temporarily |
| 83 |
)}; |
| 84 |
$REASON->{http_1_1_rfc2616} = {%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]+/, q( |
| 85 |
302 Found |
| 86 |
)}; |
| 87 |
|
| 88 |
=head1 CONSTRUCTORS |
| 89 |
|
| 90 |
The following methods construct new objects: |
| 91 |
|
| 92 |
=over 4 |
| 93 |
|
| 94 |
=cut |
| 95 |
|
| 96 |
sub _init ($;%) { |
| 97 |
my $self = shift; my %opt = @_; |
| 98 |
my $DEFAULT = Message::Util::make_clone (\%DEFAULT); |
| 99 |
$self->SUPER::_init (%$DEFAULT, %opt); |
| 100 |
|
| 101 |
my $format = $self->{option}->{format}; |
| 102 |
unless (defined $opt{-reason_unsafe_regex}) { |
| 103 |
if ($format =~ /sip/) { |
| 104 |
$self->{option}->{reason_unsafe_regex} = qr/[^\x09\x20-\x7E$REG{R_utf8_xtra}]/; |
| 105 |
} elsif ($format =~ /cgi/) { |
| 106 |
## default |
| 107 |
} else { ## HTTP |
| 108 |
$self->{option}->{reason_unsafe_regex} = qr/[^\x09\x20-\x7E\x80-\xFF]/; |
| 109 |
} |
| 110 |
} |
| 111 |
if ($format =~ /http-1\.0/) { |
| 112 |
$self->{option}->{reason_default_set} = 'http_1_0' |
| 113 |
unless defined $opt{-reason_default_set}; |
| 114 |
} elsif ($format =~ /rfc2068/) { |
| 115 |
$self->{option}->{reason_default_set} = 'http_1_1_rfc2068' |
| 116 |
unless defined $opt{-reason_default_set}; |
| 117 |
} elsif ($format =~ /sip/) { |
| 118 |
$self->{option}->{encoding_after_encode} = 'utf-8' |
| 119 |
unless defined $opt{-encoding_after_encode}; |
| 120 |
$self->{option}->{encoding_before_decode} = 'utf-8' |
| 121 |
unless defined $opt{-encoding_before_decode}; |
| 122 |
## reason_default_set = sip_2_0 |
| 123 |
} |
| 124 |
} |
| 125 |
|
| 126 |
=item $addr = Message::Field::Domain->new ([%options]) |
| 127 |
|
| 128 |
Constructs a new object. You might pass some options as parameters |
| 129 |
to the constructor. |
| 130 |
|
| 131 |
=cut |
| 132 |
|
| 133 |
## Inherited |
| 134 |
|
| 135 |
=item $addr = Message::Field::Domain->parse ($field-body, [%options]) |
| 136 |
|
| 137 |
Constructs a new object with given field body. You might pass |
| 138 |
some options as parameters to the constructor. |
| 139 |
|
| 140 |
=cut |
| 141 |
|
| 142 |
sub parse ($$;%) { |
| 143 |
my $class = shift; |
| 144 |
my $self = bless {}, $class; |
| 145 |
my $body = shift; |
| 146 |
$self->_init (@_); |
| 147 |
if ($body =~ /^([0-9]+)$REG{FWS}(.*)$/x) { |
| 148 |
$self->{value} = $1; |
| 149 |
my $r = $2; $r =~ s/^$REG{WSP}+//; $r =~ s/$REG{WSP}+$//; |
| 150 |
my %s = &{$self->{option}->{hook_decode_string}} ($self, |
| 151 |
$r, type => 'text', |
| 152 |
charset => $self->{option}->{encoding_before_decode}, |
| 153 |
); |
| 154 |
if ($s{charset}) { ## Convertion failed |
| 155 |
$self->{_charset} = $s{charset}; |
| 156 |
$self->{value} = $s{value}; |
| 157 |
return $self; |
| 158 |
} elsif (!$s{success}) { |
| 159 |
$self->{_charset} = $self->{option}->{header_default_charset_input}; |
| 160 |
$self->{value} = $s{value}; |
| 161 |
return $self; |
| 162 |
} |
| 163 |
$self->{reason_phrase} = $s{value}; |
| 164 |
}; |
| 165 |
$self; |
| 166 |
} |
| 167 |
|
| 168 |
sub value ($;$) { |
| 169 |
my $self = shift; |
| 170 |
my ($newvalue) = @_; |
| 171 |
if ($newvalue) { |
| 172 |
$self->{value} = $newvalue; |
| 173 |
} |
| 174 |
$self->{value}; |
| 175 |
} |
| 176 |
*status_code = \&value; |
| 177 |
|
| 178 |
sub reason_phrase ($;$) { |
| 179 |
my $self = shift; |
| 180 |
my ($newvalue) = @_; |
| 181 |
if ($newvalue) { |
| 182 |
$self->{reason_phrase} = $newvalue; |
| 183 |
} |
| 184 |
$self->{reason_phrase}; |
| 185 |
} |
| 186 |
|
| 187 |
sub stringify ($;%) { |
| 188 |
my $self = shift; |
| 189 |
my %o = @_; my %option = %{$self->{option}}; |
| 190 |
for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}} |
| 191 |
my $reason; |
| 192 |
if ($self->{_charset}) { |
| 193 |
$reason = $self->{reason_phrase}; |
| 194 |
} else { |
| 195 |
my (%e) = &{$option{hook_encode_string}} ($self, |
| 196 |
$self->{reason_phrase}, type => 'text', |
| 197 |
charset => $option{encoding_after_encode}, |
| 198 |
current_charset => $option{internal_charset}, |
| 199 |
); |
| 200 |
$reason = $e{value}; |
| 201 |
} |
| 202 |
my $status = $self->{value}; |
| 203 |
if (!$reason || $reason =~ /$option{reason_unsafe_regex}/) { |
| 204 |
$reason = $REASON->{ $option{reason_default_set} }{ $status }; |
| 205 |
} |
| 206 |
sprintf $option{value_pattern}, $status, $reason; |
| 207 |
} |
| 208 |
|
| 209 |
=head1 LICENSE |
| 210 |
|
| 211 |
Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>. |
| 212 |
|
| 213 |
This program is free software; you can redistribute it and/or modify |
| 214 |
it under the terms of the GNU General Public License as published by |
| 215 |
the Free Software Foundation; either version 2 of the License, or |
| 216 |
(at your option) any later version. |
| 217 |
|
| 218 |
This program is distributed in the hope that it will be useful, |
| 219 |
but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 220 |
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 221 |
GNU General Public License for more details. |
| 222 |
|
| 223 |
You should have received a copy of the GNU General Public License |
| 224 |
along with this program; see the file COPYING. If not, write to |
| 225 |
the Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 226 |
Boston, MA 02111-1307, USA. |
| 227 |
|
| 228 |
=head1 CHANGE |
| 229 |
|
| 230 |
See F<ChangeLog>. |
| 231 |
$Date: 2002/07/13 09:27:35 $ |
| 232 |
|
| 233 |
=cut |
| 234 |
|
| 235 |
1; |
Parent Directory
| 
Revision Log