Message/Field/Status.pm


=head1 NAME

Message::Field::Status --- "Status:" CGI header field

=cut

package Message::Field::Status;
use strict;
use vars qw(%DEFAULT @ISA $REASON %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);

*REG = \%Message::Util::REG;

## Initialize of this class -- called by constructors
  %DEFAULT = (
    -_MEMBERS   => [qw|reason_phrase _charset|],
    -_METHODS   => [qw|reason_phrase status_code value|],
    -encoding_after_encode      => 'iso-8859-1',
    -encoding_before_decode     => 'iso-8859-1',
    #field_param_name
    #field_name
    #field_ns
    #format
    #hook_encode_string
    #hook_decode_string
    #parse_all
    -reason_default_set => 'http_1_1_rfc2616',
    -reason_unsafe_rule => qr/[^\x20-\x7E]/,
    -value_pattern      => '%03d %s',
  );

%{ $REASON->{common} } = grep {length} split /[\t\x0D\x0A]+/, q(
        200     OK
        201     Created
        202     Accepted
        204     No Content
        301     Moved Permanently
        304     Not Modified
        400     Bad Request
        401     Unauthorized
        403     Forbidden
        404     Not Found
        500     Internal Server Error
        501     Not Implemented
        502     Bad Gateway
        503     Service Unavailable
        
        100     Continue
        101     Switching Protocols
        203     Non-Authoritative Information
        205     Reset Content
        206     Partial Content
        300     Multiple Choices
        303     See Other
        305     Use Proxy
        307     Temporary Redirect
        402     Payment Required
        405     Method Not Allowed
        406     Not Acceptable
        407     Proxy Authentication Required
        408     Request Time-out
        409     Conflict
        410     Gone
        411     Length Required
        412     Precondition Failed
        413     Request Entity Too Large
        414     Request-URI Too Large
        415     Unsupported Media Type
        416     Requested range not satisfiable
        417     Expectation Failed
        504     Gateway Time-out
        505     HTTP Version not supported
);

$REASON->{http_1_0} = {%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]+/, q(
        302     Moved Temporarily
)};
$REASON->{http_1_1_rfc2068} = {%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]+/, q(
        302     Moved Temporarily
)};
$REASON->{http_1_1_rfc2616} = {%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]+/, q(
        302     Found
)};

=head1 CONSTRUCTORS

The following methods construct new objects:

=over 4

=cut

sub _init ($;%) {
  my $self = shift;  my %opt = @_;
  my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
  $self->SUPER::_init (%$DEFAULT, %opt);
  
  my $format = $self->{option}->{format};
  unless (defined $opt{-reason_unsafe_regex}) {
    if ($format =~ /sip/) {
      $self->{option}->{reason_unsafe_regex} = qr/[^\x09\x20-\x7E$REG{R_utf8_xtra}]/;
    } elsif ($format =~ /cgi/) {
      ## default
    } else {    ## HTTP
      $self->{option}->{reason_unsafe_regex} = qr/[^\x09\x20-\x7E\x80-\xFF]/;
    }
  }
  if ($format =~ /http-1\.0/) {
    $self->{option}->{reason_default_set} = 'http_1_0'
      unless defined $opt{-reason_default_set};
  } elsif ($format =~ /rfc2068/) {
    $self->{option}->{reason_default_set} = 'http_1_1_rfc2068'
      unless defined $opt{-reason_default_set};
  } elsif ($format =~ /sip/) {
    $self->{option}->{encoding_after_encode} = 'utf-8'
      unless defined $opt{-encoding_after_encode};
    $self->{option}->{encoding_before_decode} = 'utf-8'
      unless defined $opt{-encoding_before_decode};
    ## reason_default_set = sip_2_0
  }
}

=item $addr = Message::Field::Domain->new ([%options])

Constructs a new object.  You might pass some options as parameters 
to the constructor.

=cut

## Inherited

=item $addr = Message::Field::Domain->parse ($field-body, [%options])

Constructs a new object with given field body.  You might pass 
some options as parameters to the constructor.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $self = bless {}, $class;
  my $body = shift;
  $self->_init (@_);
  if ($body =~ /^([0-9]+)$REG{FWS}(.*)$/x) {
    $self->{value} = $1;
    my $r = $2;  $r =~ s/^$REG{WSP}+//;  $r =~ s/$REG{WSP}+$//;
    my %s = &{$self->{option}->{hook_decode_string}} ($self,
      $r, type => 'text',
      charset   => $self->{option}->{encoding_before_decode},
    );
    if ($s{charset}) {  ## Convertion failed
      $self->{_charset} = $s{charset};
      $self->{value} = $s{value};
      return $self;
    } elsif (!$s{success}) {
      $self->{_charset} = $self->{option}->{header_default_charset_input};
      $self->{value} = $s{value};
      return $self;
    }
    $self->{reason_phrase} = $s{value};
  };
  $self;
}

sub value ($;$) {
  my $self = shift;
  my ($newvalue) = @_;
  if ($newvalue) {
    $self->{value} = $newvalue;
  }
  $self->{value};
}
*status_code = \&value;

sub reason_phrase ($;$) {
  my $self = shift;
  my ($newvalue) = @_;
  if ($newvalue) {
    $self->{reason_phrase} = $newvalue;
  }
  $self->{reason_phrase};
}

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my $reason;
  if ($self->{_charset}) {
    $reason = $self->{reason_phrase};
  } else {
    my (%e) = &{$option{hook_encode_string}} ($self,
      $self->{reason_phrase},  type => 'text',
      charset => $option{encoding_after_encode},
      current_charset => $option{internal_charset},
    );
    $reason = $e{value};
  }
  my $status = $self->{value};
  if (!$reason || $reason =~ /$option{reason_unsafe_regex}/) {
    $reason = $REASON->{ $option{reason_default_set} }{ $status };
  }
  sprintf $option{value_pattern}, $status, $reason;
}

=head1 LICENSE

Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; see the file COPYING.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
Boston, MA 02111-1307, USA.

=head1 CHANGE

See F<ChangeLog>.
$Date: 2002/07/13 09:27:35 $

=cut

1;
1	wakaba	1.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;