Message/Field/Numval.pm


=head1 NAME

Message::Field::Numval --- Perl module for
Internet message header field body that takes numeric values

=cut

package Message::Field::Numval;
use strict;
use vars qw(@ISA $VERSION);
$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
require Message::Field::Structured;
push @ISA, qw(Message::Field::Structured);
use overload '.=' => sub { $_[0]->comment_add ($_[1]); $_[0] },
             '0+' => sub { $_[0]->{value} || $_[0]->{option}->{value_default} },
             '+=' => sub {
               my $n = 0;#$_[0]->{value} + $_[1];
               $_[0]->{value} = $n if $n <= $_[0]->{option}->{value_max};
               $_[0]
             },
             '-=' => sub {
               my $n = $_[0]->{value} - $_[1];
               $_[0]->{value} = $n if $_[0]->{option}->{value_min} <= $n;
               $_[0]
             },
             '*=' => sub {
               my $n = $_[0]->{value} * $_[1];
               $_[0]->{value} = $n if $n <= $_[0]->{option}->{value_max};
               $_[0]
             },
             '**=' => sub {
               my $n = $_[0]->{value} ** $_[1];
               $_[0]->{value} = $n if $n <= $_[0]->{option}->{value_max};
               $_[0]
             },
             '/=' => sub {
               my $n = $_[0]->{value} / $_[1];
               $_[0]->{value} = $n if $_[0]->{option}->{value_min} <= $n;
               $_[0]
             },
             '%=' => sub {
               my $n = $_[0]->{value} % $_[1];
               $_[0]->{value} = $n if $_[0]->{option}->{value_min} <= $n;
               $_[0]
             },
             'eq' => sub { $_[0]->stringify eq $_[1] },
             'ne' => sub { $_[0]->stringify eq $_[1] },
             fallback => 1;

=head1 CONSTRUCTORS

The following methods construct new C<Message::Field::Numval> objects:

=over 4

=cut

## Initialize of this class -- called by constructors
sub _init ($;%) {
  my $self = shift;
  my %options = @_;
  my %DEFAULT = (
    -check_max  => 0,
    -check_min  => 1,
    #encoding_after_encode      ## Inherited
    #encoding_before_decode     ## Inherited
    -field_name => 'lines',
    -field_param_name   => '',
    -format_pattern     => '%d',
    #hook_encode_string ## Inherited
    #hook_decode_string ## Inherited
    -output_comment     => 0,
    -use_comment        => 0,
    -value_default      => 0,
    -value_if_invalid   => '',
    -value_max  => 100,
    -value_min  => 0,
  );
  $self->SUPER::_init (%DEFAULT, %options);
  $self->{value} = $self->{options}->{value_default};
  $self->{value} = $options{value} if defined $options{value};
  $self->{comment} = [];
  if (ref $options{comment} eq 'ARRAY') {
    push @{$self->{comment}}, @{$options{comment}};
  } elsif (defined $options{comment}) {
    push @{$self->{comment}}, $options{comment};
  }
  
  my $fname = lc $self->{option}->{field_name};
  my $pname = lc $self->{option}->{field_param_name};
  if ($fname eq 'mime-version') {
    $self->{option}->{output_comment} = 1;
    $self->{option}->{use_comment} = 1;
    $self->{option}->{format_pattern} = '%1.1f';
    $self->{option}->{value_min} = 1;
  } elsif ($fname eq 'x-priority' || $fname eq 'x-jsmail-priority') {
    $self->{option}->{output_comment} = 1;
    $self->{option}->{use_comment} = 1;
    $self->{option}->{check_max} = 1;
    $self->{option}->{check_min} = 1;
    $self->{option}->{value_min} = 1;   ## Highest
    $self->{option}->{value_max} = 5;   ## some implemention uses larger number...
  } elsif ($fname eq 'auto-submitted' && $pname eq 'increment') {
    $self->{option}->{output_comment} = 0;
    $self->{option}->{check_min} = 1;
    $self->{option}->{value_min} = 0;
    $self->{option}->{value_if_invalid} = undef;
  }
}

=item Message::Field::Numval->new ([%options])

Constructs a new C<Message::Field::Numval> object.  You might pass some 
options as parameters to the constructor.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {}, $class;
  $self->_init (@_);
  $self;
}

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

Constructs a new C<Message::Field::Numval> 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 $fb = shift;
  $self->_init (@_);
  push @{$self->{comment}}, $self->Message::Util::comment_to_array ($fb)
    if $self->{option}->{use_comment};
  $fb =~ s/[^0-9.-]//g;
  $self->{value} = $& if $fb =~ /-?[0-9]+(\.[0-9]+)?/;
  $self;
}

=back

=head1 METHODS FOR FIELD BODY VALUE

=over 4

=item $self->value ([$new_value])

Returns or set value.  Note that this method
does not check whether value is valid or not.

=item $self->value_formatted ()

Returns formatted value string.  Note that this method
does not check whether value is valid or not.
To check min/max value, use C<stringify> with
C<output_comment = -1> option (if necessary).

=cut

sub value ($;$%) {
  my $self = shift;
  my $new_value = shift;
  if ($new_value) {
    $self->{value} = $new_value;
  }
  $self->{value};
}

sub value_formatted ($;%) {
  my $self = shift;
  my %option = @_;
  $option{format_pattern} = $self->{option}->{format_pattern}
    unless defined $option{format_pattern};
  sprintf $option{format_pattern}, $self->{value};
}

=item $self->comment ()

Returns array reference of comments.  You can add/remove/change
array values.

=cut

sub comment ($) {
  my $self = shift;
  $self->{comment};
}

=item $self->comment_add ($comment, [%option]

Adds a C<comment>.  Comments are outputed only when
the class option (not an option of this method!)
 C<output_comment> is enabled (value C<1>).

On this method, only one option, C<prepend> is available.
With this option, additional comment is prepend
to current comments.  (Default value is C<-1>, append.)

=cut

sub comment_add ($$;%) {
  my $self = shift;
  my ($value, %option) = (shift, @_);
  if ($option{prepend}) {
    unshift @{$self->{comment}}, $value;
  } else {
    push @{$self->{comment}}, $value;
  }
  $self;
}

=item $self->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %o = @_;  my %option = %{$self->{option}};
  for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
  return $option{value_if_invalid}
    if $option{check_max} && $option{value_max} < $self->{value};
  return $option{value_if_invalid}
    if $option{check_min} && $option{value_min} > $self->{value};
  my $s = sprintf $option{format_pattern}, $self->{value};
  if ($option{use_comment} && $option{output_comment}) {
    for (@{$self->{comment}}) {
      my $t = $self->Message::Util::encode_ccontent ($_);
      $s .= ' ('.$t.')' if length $t;
    }
  }
  $s;
}
*as_string = \&stringify;

=back

=over 4

=item $self->option ( $option-name / $option-name, $option-value, ...)

Set/gets option value(s).  You can pass multiple option name-value pair
as parameter when setting.

=cut

## Inherited

=item $self->clone ()

Returns a copy of the object.

=cut

## Inherited

=back

=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/06/09 11:08:28 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.4	Message::Field::Numval --- Perl module for
5	wakaba	1.2	Internet message header field body that takes numeric values
6	wakaba	1.1
7			=cut
8
9			package Message::Field::Numval;
10			use strict;
11	wakaba	1.2	use vars qw(@ISA $VERSION);
12	wakaba	1.6	$VERSION=do{my @r=(q$Revision: 1.5 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	wakaba	1.1	require Message::Util;
14	wakaba	1.2	require Message::Field::Structured;
15			push @ISA, qw(Message::Field::Structured);
16	wakaba	1.3	use overload '.=' => sub { $_[0]->comment_add ($_[1]); $_[0] },
17	wakaba	1.2	'0+' => sub { $_[0]->{value} \|\| $_[0]->{option}->{value_default} },
18			'+=' => sub {
19	wakaba	1.4	my $n = 0;#$_[0]->{value} + $_[1];
20	wakaba	1.2	$_[0]->{value} = $n if $n <= $_[0]->{option}->{value_max};
21			$_[0]
22			},
23			'-=' => sub {
24			my $n = $_[0]->{value} - $_[1];
25			$_[0]->{value} = $n if $_[0]->{option}->{value_min} <= $n;
26			$_[0]
27			},
28			'*=' => sub {
29			my $n = $_[0]->{value} * $_[1];
30			$_[0]->{value} = $n if $n <= $_[0]->{option}->{value_max};
31			$_[0]
32			},
33			'**=' => sub {
34			my $n = $_[0]->{value} ** $_[1];
35			$_[0]->{value} = $n if $n <= $_[0]->{option}->{value_max};
36			$_[0]
37			},
38			'/=' => sub {
39			my $n = $_[0]->{value} / $_[1];
40			$_[0]->{value} = $n if $_[0]->{option}->{value_min} <= $n;
41			$_[0]
42			},
43			'%=' => sub {
44			my $n = $_[0]->{value} % $_[1];
45			$_[0]->{value} = $n if $_[0]->{option}->{value_min} <= $n;
46			$_[0]
47			},
48			'eq' => sub { $_[0]->stringify eq $_[1] },
49			'ne' => sub { $_[0]->stringify eq $_[1] },
50			fallback => 1;
51
52			=head1 CONSTRUCTORS
53	wakaba	1.1
54	wakaba	1.2	The following methods construct new C<Message::Field::Numval> objects:
55	wakaba	1.1
56	wakaba	1.2	=over 4
57	wakaba	1.1
58	wakaba	1.2	=cut
59
60			## Initialize of this class -- called by constructors
61			sub _init ($;%) {
62	wakaba	1.1	my $self = shift;
63	wakaba	1.2	my %options = @_;
64			my %DEFAULT = (
65			-check_max => 0,
66			-check_min => 1,
67			#encoding_after_encode ## Inherited
68			#encoding_before_decode ## Inherited
69			-field_name => 'lines',
70	wakaba	1.4	-field_param_name => '',
71	wakaba	1.2	-format_pattern => '%d',
72			#hook_encode_string ## Inherited
73			#hook_decode_string ## Inherited
74			-output_comment => 0,
75	wakaba	1.5	-use_comment => 0,
76	wakaba	1.2	-value_default => 0,
77			-value_if_invalid => '',
78			-value_max => 100,
79			-value_min => 0,
80			);
81			$self->SUPER::_init (%DEFAULT, %options);
82			$self->{value} = $self->{options}->{value_default};
83			$self->{value} = $options{value} if defined $options{value};
84			$self->{comment} = [];
85	wakaba	1.6	if (ref $options{comment} eq 'ARRAY') {
86			push @{$self->{comment}}, @{$options{comment}};
87			} elsif (defined $options{comment}) {
88			push @{$self->{comment}}, $options{comment};
89			}
90	wakaba	1.2
91	wakaba	1.1	my $fname = lc $self->{option}->{field_name};
92	wakaba	1.4	my $pname = lc $self->{option}->{field_param_name};
93	wakaba	1.1	if ($fname eq 'mime-version') {
94			$self->{option}->{output_comment} = 1;
95	wakaba	1.5	$self->{option}->{use_comment} = 1;
96	wakaba	1.1	$self->{option}->{format_pattern} = '%1.1f';
97	wakaba	1.2	$self->{option}->{value_min} = 1;
98			} elsif ($fname eq 'x-priority' \|\| $fname eq 'x-jsmail-priority') {
99			$self->{option}->{output_comment} = 1;
100	wakaba	1.5	$self->{option}->{use_comment} = 1;
101	wakaba	1.1	$self->{option}->{check_max} = 1;
102	wakaba	1.2	$self->{option}->{check_min} = 1;
103			$self->{option}->{value_min} = 1; ## Highest
104			$self->{option}->{value_max} = 5; ## some implemention uses larger number...
105	wakaba	1.4	} elsif ($fname eq 'auto-submitted' && $pname eq 'increment') {
106			$self->{option}->{output_comment} = 0;
107			$self->{option}->{check_min} = 1;
108			$self->{option}->{value_min} = 0;
109			$self->{option}->{value_if_invalid} = undef;
110	wakaba	1.1	}
111			}
112
113	wakaba	1.2	=item Message::Field::Numval->new ([%options])
114	wakaba	1.1
115	wakaba	1.2	Constructs a new C<Message::Field::Numval> object. You might pass some
116			options as parameters to the constructor.
117	wakaba	1.1
118			=cut
119
120			sub new ($;%) {
121			my $class = shift;
122	wakaba	1.2	my $self = bless {}, $class;
123			$self->_init (@_);
124	wakaba	1.1	$self;
125			}
126
127	wakaba	1.2	=item Message::Field::Numval->parse ($field-body, [%options])
128	wakaba	1.1
129	wakaba	1.2	Constructs a new C<Message::Field::Numval> object with
130			given field body. You might pass some options as parameters to the constructor.
131	wakaba	1.1
132			=cut
133
134			sub parse ($$;%) {
135			my $class = shift;
136	wakaba	1.2	my $self = bless {}, $class;
137			my $fb = shift;
138			$self->_init (@_);
139	wakaba	1.5	push @{$self->{comment}}, $self->Message::Util::comment_to_array ($fb)
140			if $self->{option}->{use_comment};
141	wakaba	1.2	$fb =~ s/[^0-9.-]//g;
142			$self->{value} = $& if $fb =~ /-?[0-9]+(\.[0-9]+)?/;
143	wakaba	1.1	$self;
144			}
145
146	wakaba	1.2	=back
147
148			=head1 METHODS FOR FIELD BODY VALUE
149
150			=over 4
151
152			=item $self->value ([$new_value])
153	wakaba	1.1
154			Returns or set value. Note that this method
155			does not check whether value is valid or not.
156
157	wakaba	1.2	=item $self->value_formatted ()
158	wakaba	1.1
159			Returns formatted value string. Note that this method
160			does not check whether value is valid or not.
161			To check min/max value, use C<stringify> with
162			C<output_comment = -1> option (if necessary).
163
164			=cut
165
166			sub value ($;$%) {
167			my $self = shift;
168			my $new_value = shift;
169			if ($new_value) {
170			$self->{value} = $new_value;
171			}
172			$self->{value};
173			}
174
175			sub value_formatted ($;%) {
176			my $self = shift;
177			my %option = @_;
178			$option{format_pattern} = $self->{option}->{format_pattern}
179			unless defined $option{format_pattern};
180			sprintf $option{format_pattern}, $self->{value};
181			}
182
183	wakaba	1.2	=item $self->comment ()
184
185			Returns array reference of comments. You can add/remove/change
186			array values.
187
188			=cut
189
190			sub comment ($) {
191			my $self = shift;
192			$self->{comment};
193			}
194
195			=item $self->comment_add ($comment, [%option]
196	wakaba	1.1
197			Adds a C<comment>. Comments are outputed only when
198			the class option (not an option of this method!)
199			C<output_comment> is enabled (value C<1>).
200
201			On this method, only one option, C<prepend> is available.
202			With this option, additional comment is prepend
203			to current comments. (Default value is C<-1>, append.)
204
205			=cut
206
207			sub comment_add ($$;%) {
208			my $self = shift;
209			my ($value, %option) = (shift, @_);
210			if ($option{prepend}) {
211			unshift @{$self->{comment}}, $value;
212			} else {
213			push @{$self->{comment}}, $value;
214			}
215			$self;
216			}
217
218	wakaba	1.2	=item $self->stringify ()
219	wakaba	1.1
220			Returns C<field-body> as a string.
221
222			=cut
223
224			sub stringify ($;%) {
225			my $self = shift;
226	wakaba	1.5	my %o = @_; my %option = %{$self->{option}};
227			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
228	wakaba	1.1	return $option{value_if_invalid}
229	wakaba	1.2	if $option{check_max} && $option{value_max} < $self->{value};
230	wakaba	1.1	return $option{value_if_invalid}
231	wakaba	1.2	if $option{check_min} && $option{value_min} > $self->{value};
232	wakaba	1.1	my $s = sprintf $option{format_pattern}, $self->{value};
233	wakaba	1.5	if ($option{use_comment} && $option{output_comment}) {
234	wakaba	1.1	for (@{$self->{comment}}) {
235	wakaba	1.2	my $t = $self->Message::Util::encode_ccontent ($_);
236			$s .= ' ('.$t.')' if length $t;
237	wakaba	1.1	}
238			}
239			$s;
240			}
241	wakaba	1.2	*as_string = \&stringify;
242
243			=back
244	wakaba	1.1
245	wakaba	1.2	=over 4
246
247			=item $self->option ( $option-name / $option-name, $option-value, ...)
248
249			Set/gets option value(s). You can pass multiple option name-value pair
250			as parameter when setting.
251
252			=cut
253
254			## Inherited
255
256			=item $self->clone ()
257
258			Returns a copy of the object.
259
260			=cut
261
262			## Inherited
263
264			=back
265	wakaba	1.1
266			=head1 LICENSE
267
268			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
269
270			This program is free software; you can redistribute it and/or modify
271			it under the terms of the GNU General Public License as published by
272			the Free Software Foundation; either version 2 of the License, or
273			(at your option) any later version.
274
275			This program is distributed in the hope that it will be useful,
276			but WITHOUT ANY WARRANTY; without even the implied warranty of
277			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
278			GNU General Public License for more details.
279
280			You should have received a copy of the GNU General Public License
281			along with this program; see the file COPYING. If not, write to
282			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
283			Boston, MA 02111-1307, USA.
284
285			=head1 CHANGE
286
287			See F<ChangeLog>.
288	wakaba	1.6	$Date: 2002/06/09 11:08:28 $
289	wakaba	1.1
290			=cut
291
292			1;