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