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.4 $=~/\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} = [];
  push @{$self->{comment}}, $options{comment} if length $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/04/22 08:28:20 $

=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.5	$VERSION=do{my @r=(q$Revision: 1.4 $=~/\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			push @{$self->{comment}}, $options{comment} if length $options{comment};
86
87	wakaba	1.1	my $fname = lc $self->{option}->{field_name};
88	wakaba	1.4	my $pname = lc $self->{option}->{field_param_name};
89	wakaba	1.1	if ($fname eq 'mime-version') {
90			$self->{option}->{output_comment} = 1;
91	wakaba	1.5	$self->{option}->{use_comment} = 1;
92	wakaba	1.1	$self->{option}->{format_pattern} = '%1.1f';
93	wakaba	1.2	$self->{option}->{value_min} = 1;
94			} elsif ($fname eq 'x-priority' \|\| $fname eq 'x-jsmail-priority') {
95			$self->{option}->{output_comment} = 1;
96	wakaba	1.5	$self->{option}->{use_comment} = 1;
97	wakaba	1.1	$self->{option}->{check_max} = 1;
98	wakaba	1.2	$self->{option}->{check_min} = 1;
99			$self->{option}->{value_min} = 1; ## Highest
100			$self->{option}->{value_max} = 5; ## some implemention uses larger number...
101	wakaba	1.4	} elsif ($fname eq 'auto-submitted' && $pname eq 'increment') {
102			$self->{option}->{output_comment} = 0;
103			$self->{option}->{check_min} = 1;
104			$self->{option}->{value_min} = 0;
105			$self->{option}->{value_if_invalid} = undef;
106	wakaba	1.1	}
107			}
108
109	wakaba	1.2	=item Message::Field::Numval->new ([%options])
110	wakaba	1.1
111	wakaba	1.2	Constructs a new C<Message::Field::Numval> object. You might pass some
112			options as parameters to the constructor.
113	wakaba	1.1
114			=cut
115
116			sub new ($;%) {
117			my $class = shift;
118	wakaba	1.2	my $self = bless {}, $class;
119			$self->_init (@_);
120	wakaba	1.1	$self;
121			}
122
123	wakaba	1.2	=item Message::Field::Numval->parse ($field-body, [%options])
124	wakaba	1.1
125	wakaba	1.2	Constructs a new C<Message::Field::Numval> object with
126			given field body. You might pass some options as parameters to the constructor.
127	wakaba	1.1
128			=cut
129
130			sub parse ($$;%) {
131			my $class = shift;
132	wakaba	1.2	my $self = bless {}, $class;
133			my $fb = shift;
134			$self->_init (@_);
135	wakaba	1.5	push @{$self->{comment}}, $self->Message::Util::comment_to_array ($fb)
136			if $self->{option}->{use_comment};
137	wakaba	1.2	$fb =~ s/[^0-9.-]//g;
138			$self->{value} = $& if $fb =~ /-?[0-9]+(\.[0-9]+)?/;
139	wakaba	1.1	$self;
140			}
141
142	wakaba	1.2	=back
143
144			=head1 METHODS FOR FIELD BODY VALUE
145
146			=over 4
147
148			=item $self->value ([$new_value])
149	wakaba	1.1
150			Returns or set value. Note that this method
151			does not check whether value is valid or not.
152
153	wakaba	1.2	=item $self->value_formatted ()
154	wakaba	1.1
155			Returns formatted value string. Note that this method
156			does not check whether value is valid or not.
157			To check min/max value, use C<stringify> with
158			C<output_comment = -1> option (if necessary).
159
160			=cut
161
162			sub value ($;$%) {
163			my $self = shift;
164			my $new_value = shift;
165			if ($new_value) {
166			$self->{value} = $new_value;
167			}
168			$self->{value};
169			}
170
171			sub value_formatted ($;%) {
172			my $self = shift;
173			my %option = @_;
174			$option{format_pattern} = $self->{option}->{format_pattern}
175			unless defined $option{format_pattern};
176			sprintf $option{format_pattern}, $self->{value};
177			}
178
179	wakaba	1.2	=item $self->comment ()
180
181			Returns array reference of comments. You can add/remove/change
182			array values.
183
184			=cut
185
186			sub comment ($) {
187			my $self = shift;
188			$self->{comment};
189			}
190
191			=item $self->comment_add ($comment, [%option]
192	wakaba	1.1
193			Adds a C<comment>. Comments are outputed only when
194			the class option (not an option of this method!)
195			C<output_comment> is enabled (value C<1>).
196
197			On this method, only one option, C<prepend> is available.
198			With this option, additional comment is prepend
199			to current comments. (Default value is C<-1>, append.)
200
201			=cut
202
203			sub comment_add ($$;%) {
204			my $self = shift;
205			my ($value, %option) = (shift, @_);
206			if ($option{prepend}) {
207			unshift @{$self->{comment}}, $value;
208			} else {
209			push @{$self->{comment}}, $value;
210			}
211			$self;
212			}
213
214	wakaba	1.2	=item $self->stringify ()
215	wakaba	1.1
216			Returns C<field-body> as a string.
217
218			=cut
219
220			sub stringify ($;%) {
221			my $self = shift;
222	wakaba	1.5	my %o = @_; my %option = %{$self->{option}};
223			for (grep {/^-/} keys %o) {$option{substr ($_, 1)} = $o{$_}}
224	wakaba	1.1	return $option{value_if_invalid}
225	wakaba	1.2	if $option{check_max} && $option{value_max} < $self->{value};
226	wakaba	1.1	return $option{value_if_invalid}
227	wakaba	1.2	if $option{check_min} && $option{value_min} > $self->{value};
228	wakaba	1.1	my $s = sprintf $option{format_pattern}, $self->{value};
229	wakaba	1.5	if ($option{use_comment} && $option{output_comment}) {
230	wakaba	1.1	for (@{$self->{comment}}) {
231	wakaba	1.2	my $t = $self->Message::Util::encode_ccontent ($_);
232			$s .= ' ('.$t.')' if length $t;
233	wakaba	1.1	}
234			}
235			$s;
236			}
237	wakaba	1.2	*as_string = \&stringify;
238
239			=back
240	wakaba	1.1
241	wakaba	1.2	=over 4
242
243			=item $self->option ( $option-name / $option-name, $option-value, ...)
244
245			Set/gets option value(s). You can pass multiple option name-value pair
246			as parameter when setting.
247
248			=cut
249
250			## Inherited
251
252			=item $self->clone ()
253
254			Returns a copy of the object.
255
256			=cut
257
258			## Inherited
259
260			=back
261	wakaba	1.1
262			=head1 LICENSE
263
264			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
265
266			This program is free software; you can redistribute it and/or modify
267			it under the terms of the GNU General Public License as published by
268			the Free Software Foundation; either version 2 of the License, or
269			(at your option) any later version.
270
271			This program is distributed in the hope that it will be useful,
272			but WITHOUT ANY WARRANTY; without even the implied warranty of
273			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
274			GNU General Public License for more details.
275
276			You should have received a copy of the GNU General Public License
277			along with this program; see the file COPYING. If not, write to
278			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
279			Boston, MA 02111-1307, USA.
280
281			=head1 CHANGE
282
283			See F<ChangeLog>.
284	wakaba	1.5	$Date: 2002/04/22 08:28:20 $
285	wakaba	1.1
286			=cut
287
288			1;