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.3 $=~/\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,
    -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}->{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}->{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);
  $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 %option = @_;
  for (qw(check_max check_min output_comment value_max value_min value_if_invalid)) {
    $option{$_} ||= $self->{option}->{$_};
  }
  $option{format_pattern} = $self->{option}->{format_pattern}
    unless defined $option{format_pattern};
  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{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/13 01:33:54 $

=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.4	$VERSION=do{my @r=(q$Revision: 1.3 $=~/\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			-value_default => 0,
76			-value_if_invalid => '',
77			-value_max => 100,
78			-value_min => 0,
79			);
80			$self->SUPER::_init (%DEFAULT, %options);
81			$self->{value} = $self->{options}->{value_default};
82			$self->{value} = $options{value} if defined $options{value};
83			$self->{comment} = [];
84			push @{$self->{comment}}, $options{comment} if length $options{comment};
85
86	wakaba	1.1	my $fname = lc $self->{option}->{field_name};
87	wakaba	1.4	my $pname = lc $self->{option}->{field_param_name};
88	wakaba	1.1	if ($fname eq 'mime-version') {
89			$self->{option}->{output_comment} = 1;
90			$self->{option}->{format_pattern} = '%1.1f';
91	wakaba	1.2	$self->{option}->{value_min} = 1;
92			} elsif ($fname eq 'x-priority' \|\| $fname eq 'x-jsmail-priority') {
93			$self->{option}->{output_comment} = 1;
94	wakaba	1.1	$self->{option}->{check_max} = 1;
95	wakaba	1.2	$self->{option}->{check_min} = 1;
96			$self->{option}->{value_min} = 1; ## Highest
97			$self->{option}->{value_max} = 5; ## some implemention uses larger number...
98	wakaba	1.4	} elsif ($fname eq 'auto-submitted' && $pname eq 'increment') {
99			$self->{option}->{output_comment} = 0;
100			$self->{option}->{check_min} = 1;
101			$self->{option}->{value_min} = 0;
102			$self->{option}->{value_if_invalid} = undef;
103	wakaba	1.1	}
104			}
105
106	wakaba	1.2	=item Message::Field::Numval->new ([%options])
107	wakaba	1.1
108	wakaba	1.2	Constructs a new C<Message::Field::Numval> object. You might pass some
109			options as parameters to the constructor.
110	wakaba	1.1
111			=cut
112
113			sub new ($;%) {
114			my $class = shift;
115	wakaba	1.2	my $self = bless {}, $class;
116			$self->_init (@_);
117	wakaba	1.1	$self;
118			}
119
120	wakaba	1.2	=item Message::Field::Numval->parse ($field-body, [%options])
121	wakaba	1.1
122	wakaba	1.2	Constructs a new C<Message::Field::Numval> object with
123			given field body. You might pass some options as parameters to the constructor.
124	wakaba	1.1
125			=cut
126
127			sub parse ($$;%) {
128			my $class = shift;
129	wakaba	1.2	my $self = bless {}, $class;
130			my $fb = shift;
131			$self->_init (@_);
132			push @{$self->{comment}}, $self->Message::Util::comment_to_array ($fb);
133			$fb =~ s/[^0-9.-]//g;
134			$self->{value} = $& if $fb =~ /-?[0-9]+(\.[0-9]+)?/;
135	wakaba	1.1	$self;
136			}
137
138	wakaba	1.2	=back
139
140			=head1 METHODS FOR FIELD BODY VALUE
141
142			=over 4
143
144			=item $self->value ([$new_value])
145	wakaba	1.1
146			Returns or set value. Note that this method
147			does not check whether value is valid or not.
148
149	wakaba	1.2	=item $self->value_formatted ()
150	wakaba	1.1
151			Returns formatted value string. Note that this method
152			does not check whether value is valid or not.
153			To check min/max value, use C<stringify> with
154			C<output_comment = -1> option (if necessary).
155
156			=cut
157
158			sub value ($;$%) {
159			my $self = shift;
160			my $new_value = shift;
161			if ($new_value) {
162			$self->{value} = $new_value;
163			}
164			$self->{value};
165			}
166
167			sub value_formatted ($;%) {
168			my $self = shift;
169			my %option = @_;
170			$option{format_pattern} = $self->{option}->{format_pattern}
171			unless defined $option{format_pattern};
172			sprintf $option{format_pattern}, $self->{value};
173			}
174
175	wakaba	1.2	=item $self->comment ()
176
177			Returns array reference of comments. You can add/remove/change
178			array values.
179
180			=cut
181
182			sub comment ($) {
183			my $self = shift;
184			$self->{comment};
185			}
186
187			=item $self->comment_add ($comment, [%option]
188	wakaba	1.1
189			Adds a C<comment>. Comments are outputed only when
190			the class option (not an option of this method!)
191			C<output_comment> is enabled (value C<1>).
192
193			On this method, only one option, C<prepend> is available.
194			With this option, additional comment is prepend
195			to current comments. (Default value is C<-1>, append.)
196
197			=cut
198
199			sub comment_add ($$;%) {
200			my $self = shift;
201			my ($value, %option) = (shift, @_);
202			if ($option{prepend}) {
203			unshift @{$self->{comment}}, $value;
204			} else {
205			push @{$self->{comment}}, $value;
206			}
207			$self;
208			}
209
210	wakaba	1.2	=item $self->stringify ()
211	wakaba	1.1
212			Returns C<field-body> as a string.
213
214			=cut
215
216			sub stringify ($;%) {
217			my $self = shift;
218			my %option = @_;
219	wakaba	1.2	for (qw(check_max check_min output_comment value_max value_min value_if_invalid)) {
220			$option{$_} \|\|= $self->{option}->{$_};
221			}
222	wakaba	1.1	$option{format_pattern} = $self->{option}->{format_pattern}
223			unless defined $option{format_pattern};
224			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.2	if ($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.4	$Date: 2002/04/13 01:33:54 $
285	wakaba	1.1
286			=cut
287
288			1;