Message/Field/Warning.pm


=head1 NAME

Message::Field::Warning --- A element of "Warning:" HTTP general header field

=cut

package Message::Field::Warning;
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|warn_agent warn_text warn_date|],
    -_METHODS   => [qw|value warn_code warn_agent warn_text warn_date|],
    -encoding_after_encode      => 'iso-8859-1',
    -encoding_before_decode     => 'iso-8859-1',
    #field_param_name
    #field_name
    #field_ns
    -fill_warn_date     => 0,
    #format
    #hook_encode_string
    #hook_decode_string
    -output_two_digit   => 0,
    #parse_all
    -reason_default_set => 'http_1_1_rfc2616',
    -use_warn_date      => 1,
    -value_pattern      => '%03d %s %s%s',
  );

%{ $REASON->{common} } = grep {length} split /[\t\x0D\x0A]+/, q(
        10      Response is stale
        11      Revalidation failed
        12      Disconnected operation
        13      Heuristic expiration
        14      Transformation applied
        99      Miscellaneous warning
        
        110     Response is stale
        111     Revalidation failed
        112     Disconnected operation
        113     Heuristic expiration
        199     Miscellaneous warning
        214     Transformation applied
        299     Miscellaneous persistent warning
        
        300     Incompatible network protocol
        301     Incompatible network address formats
        302     Incompatible transport protocol
        303     Incompatible bandwidth units
        304     Media type not available
        305     Incompatible media format
        306     Attribute not understood
        307     Session description parameter not understood
        330     Multicast not available
        331     Unicast not available
        370     Insufficient bandwidth
        399     Miscellaneous warning
);

#%{ $REASON->{http_1_0} } = (%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]#+/, q(
#));
$REASON->{http_1_0} = $REASON->{common};        ## Warning is not defined by RFC 1945
$REASON->{http_1_1_rfc2068} = $REASON->{common};
$REASON->{http_1_1_rfc2616} = $REASON->{common};
$REASON->{sip_2_0} = $REASON->{common};

my %_two_to_three = qw(10 110 11 111 12 112 13 113 14 214 99 199);
my %_three_to_two = reverse %_two_to_three;

=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};
  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};
    $self->{option}->{value_pattern} = '%02d %s %s'
      unless defined $opt{-value_pattern};
    $self->{option}->{output_two_digit} = 1 unless defined $opt{-output_two_digit};
  } 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};
    $self->{option}->{reason_default_set} = 'sip_2_0'
      unless defined $opt{-reason_default_set};
    $self->{option}->{value_pattern} = '%03d %s %s'
      unless defined $opt{-value_pattern};
  }
  
  $self->{option}->{value_type}->{warn_agent} = ['Message::Field::Domain',{
        -fill_default_value     => 1,
        -fill_default_name      => 1,
        -fill_default_port      => 0,
        -format_ipv4    => '%vd',
        -format_ipv6    => '%s',
        -output_comment => 0,
        -output_port    => 1,
        -use_port       => 1,
  }];
  $self->{option}->{value_type}->{warn_date} = ['Message::Field::Date',{
        -output_comment => 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}($REG{token}(?::[0-9]+)?)$REG{FWS}$REG{M_quoted_string}(?:$REG{FWS}$REG{M_quoted_string})?/x) {
    $self->{value} = 0+$1;
    $self->{value} = $_two_to_three{ $self->{value} } || $self->{value};
    $self->{warn_agent} = $2;
    $self->{warn_date} = $4;
    my %s = &{$self->{option}->{hook_decode_string}} ($self,
      $3, 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->{warn_agent} = $self->_parse_value (warn_agent => $self->{warn_agent})
      if $self->{option}->{parse_all};
    $self->{warn_date} = $self->_parse_value (warn_date => $self->{warn_date})
      if $self->{option}->{parse_all};
    $self->{warn_text} = $s{value};
  } else {
    $self->{value} = 0;
    $self->{warn_text} = '';
    $self->{warn_agent} = '';
    $self->{warn_date} = '';
  }
  $self;
}

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

sub warn_agent ($;$) {
  my $self = shift;
  my ($newvalue) = @_;
  if ($newvalue) {
    $self->{warn_agent} = $newvalue;
  }
  $self->{warn_agent} = $self->_parse_value (warn_agent => $self->{warn_agent})
    if $self->{option}->{parse_all};
  $self->{warn_agent};
}

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

sub warn_date ($;$) {
  my $self = shift;
  my ($newvalue) = @_;
  if ($newvalue) {
    $self->{warn_date} = $newvalue;
  }
  $self->{warn_date} = $self->_parse_value (warn_date => $self->{warn_date})
    if $self->{option}->{parse_all};
  $self->{warn_date};
}

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  my $status = $self->{value};
  return '' unless $status;
  $status = $_three_to_two{$status} || $status if $option{output_two_digit};
  $status += 0;
  my ($host, $reason, $date);
  $host = $self->warn_agent;
  $date = $self->warn_date;
  if ($date == 0 && $option{fill_warn_date}) {
    $self->{warn_date}->unix_time (time);
  }
  if ($date == 0 || !$option{use_warn_date}) {
    $date = '';
  } else {
    $date = ' '.Message::Util::quote_unsafe_string ($date, unsafe => 'MATCH_ALL');
  }
  if ($self->{_charset}) {
    $reason = $self->{warn_text};
  } else {
    my (%e) = &{$option{hook_encode_string}} ($self,
      $self->{warn_text},  type => 'text',
      charset => $option{encoding_after_encode},
      current_charset => $option{internal_charset},
    );
    $reason = $e{value};
  }
  if (!$reason) {
    $reason = $REASON->{ $option{reason_default_set} }{ $status };
  }
  $reason = Message::Util::quote_unsafe_string ($reason, unsafe => 'MATCH_ALL') || '""';
  sprintf $option{value_pattern}, $status, $host, $reason, $date;
}

=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::Warning --- A element of "Warning:" HTTP general header field
5
6			=cut
7
8			package Message::Field::Warning;
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\|warn_agent warn_text warn_date\|],
20			-_METHODS => [qw\|value warn_code warn_agent warn_text warn_date\|],
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			-fill_warn_date => 0,
27			#format
28			#hook_encode_string
29			#hook_decode_string
30			-output_two_digit => 0,
31			#parse_all
32			-reason_default_set => 'http_1_1_rfc2616',
33			-use_warn_date => 1,
34			-value_pattern => '%03d %s %s%s',
35			);
36
37			%{ $REASON->{common} } = grep {length} split /[\t\x0D\x0A]+/, q(
38			10 Response is stale
39			11 Revalidation failed
40			12 Disconnected operation
41			13 Heuristic expiration
42			14 Transformation applied
43			99 Miscellaneous warning
44
45			110 Response is stale
46			111 Revalidation failed
47			112 Disconnected operation
48			113 Heuristic expiration
49			199 Miscellaneous warning
50			214 Transformation applied
51			299 Miscellaneous persistent warning
52
53			300 Incompatible network protocol
54			301 Incompatible network address formats
55			302 Incompatible transport protocol
56			303 Incompatible bandwidth units
57			304 Media type not available
58			305 Incompatible media format
59			306 Attribute not understood
60			307 Session description parameter not understood
61			330 Multicast not available
62			331 Unicast not available
63			370 Insufficient bandwidth
64			399 Miscellaneous warning
65			);
66
67			#%{ $REASON->{http_1_0} } = (%{ $REASON->{common} }, grep {length} split /[\t\x0D\x0A]#+/, q(
68			#));
69			$REASON->{http_1_0} = $REASON->{common}; ## Warning is not defined by RFC 1945
70			$REASON->{http_1_1_rfc2068} = $REASON->{common};
71			$REASON->{http_1_1_rfc2616} = $REASON->{common};
72			$REASON->{sip_2_0} = $REASON->{common};
73
74			my %_two_to_three = qw(10 110 11 111 12 112 13 113 14 214 99 199);
75			my %_three_to_two = reverse %_two_to_three;
76
77			=head1 CONSTRUCTORS
78
79			The following methods construct new objects:
80
81			=over 4
82
83			=cut
84
85			sub _init ($;%) {
86			my $self = shift; my %opt = @_;
87			my $DEFAULT = Message::Util::make_clone (\%DEFAULT);
88			$self->SUPER::_init (%$DEFAULT, %opt);
89
90			my $format = $self->{option}->{format};
91			if ($format =~ /http-1\.0/) {
92			$self->{option}->{reason_default_set} = 'http_1_0'
93			unless defined $opt{-reason_default_set};
94			} elsif ($format =~ /rfc2068/) {
95			$self->{option}->{reason_default_set} = 'http_1_1_rfc2068'
96			unless defined $opt{-reason_default_set};
97			$self->{option}->{value_pattern} = '%02d %s %s'
98			unless defined $opt{-value_pattern};
99			$self->{option}->{output_two_digit} = 1 unless defined $opt{-output_two_digit};
100			} elsif ($format =~ /sip/) {
101			$self->{option}->{encoding_after_encode} = 'utf-8'
102			unless defined $opt{-encoding_after_encode};
103			$self->{option}->{encoding_before_decode} = 'utf-8'
104			unless defined $opt{-encoding_before_decode};
105			$self->{option}->{reason_default_set} = 'sip_2_0'
106			unless defined $opt{-reason_default_set};
107			$self->{option}->{value_pattern} = '%03d %s %s'
108			unless defined $opt{-value_pattern};
109			}
110
111			$self->{option}->{value_type}->{warn_agent} = ['Message::Field::Domain',{
112			-fill_default_value => 1,
113			-fill_default_name => 1,
114			-fill_default_port => 0,
115			-format_ipv4 => '%vd',
116			-format_ipv6 => '%s',
117			-output_comment => 0,
118			-output_port => 1,
119			-use_port => 1,
120			}];
121			$self->{option}->{value_type}->{warn_date} = ['Message::Field::Date',{
122			-output_comment => 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}($REG{token}(?::[0-9]+)?)$REG{FWS}$REG{M_quoted_string}(?:$REG{FWS}$REG{M_quoted_string})?/x) {
148			$self->{value} = 0+$1;
149			$self->{value} = $_two_to_three{ $self->{value} } \|\| $self->{value};
150			$self->{warn_agent} = $2;
151			$self->{warn_date} = $4;
152			my %s = &{$self->{option}->{hook_decode_string}} ($self,
153			$3, type => 'text',
154			charset => $self->{option}->{encoding_before_decode},
155			);
156			if ($s{charset}) { ## Convertion failed
157			$self->{_charset} = $s{charset};
158			$self->{value} = $s{value};
159			return $self;
160			} elsif (!$s{success}) {
161			$self->{_charset} = $self->{option}->{header_default_charset_input};
162			$self->{value} = $s{value};
163			return $self;
164			}
165			$self->{warn_agent} = $self->_parse_value (warn_agent => $self->{warn_agent})
166			if $self->{option}->{parse_all};
167			$self->{warn_date} = $self->_parse_value (warn_date => $self->{warn_date})
168			if $self->{option}->{parse_all};
169			$self->{warn_text} = $s{value};
170			} else {
171			$self->{value} = 0;
172			$self->{warn_text} = '';
173			$self->{warn_agent} = '';
174			$self->{warn_date} = '';
175			}
176			$self;
177			}
178
179			sub value ($;$) {
180			my $self = shift;
181			my ($newvalue) = @_;
182			if ($newvalue) {
183			$self->{value} = $newvalue;
184			}
185			$self->{value};
186			}
187			*warn_code = \&value;
188
189			sub warn_agent ($;$) {
190			my $self = shift;
191			my ($newvalue) = @_;
192			if ($newvalue) {
193			$self->{warn_agent} = $newvalue;
194			}
195			$self->{warn_agent} = $self->_parse_value (warn_agent => $self->{warn_agent})
196			if $self->{option}->{parse_all};
197			$self->{warn_agent};
198			}
199
200			sub warn_text ($;$) {
201			my $self = shift;
202			my ($newvalue) = @_;
203			if ($newvalue) {
204			$self->{warn_text} = $newvalue;
205			}
206			$self->{warn_text};
207			}
208
209			sub warn_date ($;$) {
210			my $self = shift;
211			my ($newvalue) = @_;
212			if ($newvalue) {
213			$self->{warn_date} = $newvalue;
214			}
215			$self->{warn_date} = $self->_parse_value (warn_date => $self->{warn_date})
216			if $self->{option}->{parse_all};
217			$self->{warn_date};
218			}
219
220			sub stringify ($;%) {
221			my $self = shift;
222			my %o = @_; my %option = %{$self->{option}};
223			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
224			my $status = $self->{value};
225			return '' unless $status;
226			$status = $_three_to_two{$status} \|\| $status if $option{output_two_digit};
227			$status += 0;
228			my ($host, $reason, $date);
229			$host = $self->warn_agent;
230			$date = $self->warn_date;
231			if ($date == 0 && $option{fill_warn_date}) {
232			$self->{warn_date}->unix_time (time);
233			}
234			if ($date == 0 \|\| !$option{use_warn_date}) {
235			$date = '';
236			} else {
237			$date = ' '.Message::Util::quote_unsafe_string ($date, unsafe => 'MATCH_ALL');
238			}
239			if ($self->{_charset}) {
240			$reason = $self->{warn_text};
241			} else {
242			my (%e) = &{$option{hook_encode_string}} ($self,
243			$self->{warn_text}, type => 'text',
244			charset => $option{encoding_after_encode},
245			current_charset => $option{internal_charset},
246			);
247			$reason = $e{value};
248			}
249			if (!$reason) {
250			$reason = $REASON->{ $option{reason_default_set} }{ $status };
251			}
252			$reason = Message::Util::quote_unsafe_string ($reason, unsafe => 'MATCH_ALL') \|\| '""';
253			sprintf $option{value_pattern}, $status, $host, $reason, $date;
254			}
255
256			=head1 LICENSE
257
258			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
259
260			This program is free software; you can redistribute it and/or modify
261			it under the terms of the GNU General Public License as published by
262			the Free Software Foundation; either version 2 of the License, or
263			(at your option) any later version.
264
265			This program is distributed in the hope that it will be useful,
266			but WITHOUT ANY WARRANTY; without even the implied warranty of
267			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
268			GNU General Public License for more details.
269
270			You should have received a copy of the GNU General Public License
271			along with this program; see the file COPYING. If not, write to
272			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
273			Boston, MA 02111-1307, USA.
274
275			=head1 CHANGE
276
277			See F<ChangeLog>.
278			$Date: 2002/07/13 09:27:35 $
279
280			=cut
281
282			1;