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.2 $=~/\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]->{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',
    -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};
  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...
  }
}

=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/05 14:55:28 $

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4	wakaba	1.2	Message::Field::Numval -- Perl module for
5			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.3	$VERSION=do{my @r=(q$Revision: 1.2 $=~/\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			my $n = $_[0]->{value} + $_[1];
20			$_[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
53			=head1 CONSTRUCTORS
54	wakaba	1.1
55	wakaba	1.2	The following methods construct new C<Message::Field::Numval> objects:
56	wakaba	1.1
57	wakaba	1.2	=over 4
58	wakaba	1.1
59	wakaba	1.2	=cut
60
61			## Initialize of this class -- called by constructors
62			sub _init ($;%) {
63	wakaba	1.1	my $self = shift;
64	wakaba	1.2	my %options = @_;
65			my %DEFAULT = (
66			-check_max => 0,
67			-check_min => 1,
68			#encoding_after_encode ## Inherited
69			#encoding_before_decode ## Inherited
70			-field_name => 'lines',
71			-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			if ($fname eq 'mime-version') {
88			$self->{option}->{output_comment} = 1;
89			$self->{option}->{format_pattern} = '%1.1f';
90	wakaba	1.2	$self->{option}->{value_min} = 1;
91			} elsif ($fname eq 'x-priority' \|\| $fname eq 'x-jsmail-priority') {
92			$self->{option}->{output_comment} = 1;
93	wakaba	1.1	$self->{option}->{check_max} = 1;
94	wakaba	1.2	$self->{option}->{check_min} = 1;
95			$self->{option}->{value_min} = 1; ## Highest
96			$self->{option}->{value_max} = 5; ## some implemention uses larger number...
97	wakaba	1.1	}
98			}
99
100	wakaba	1.2	=item Message::Field::Numval->new ([%options])
101	wakaba	1.1
102	wakaba	1.2	Constructs a new C<Message::Field::Numval> object. You might pass some
103			options as parameters to the constructor.
104	wakaba	1.1
105			=cut
106
107			sub new ($;%) {
108			my $class = shift;
109	wakaba	1.2	my $self = bless {}, $class;
110			$self->_init (@_);
111	wakaba	1.1	$self;
112			}
113
114	wakaba	1.2	=item Message::Field::Numval->parse ($field-body, [%options])
115	wakaba	1.1
116	wakaba	1.2	Constructs a new C<Message::Field::Numval> object with
117			given field body. You might pass some options as parameters to the constructor.
118	wakaba	1.1
119			=cut
120
121			sub parse ($$;%) {
122			my $class = shift;
123	wakaba	1.2	my $self = bless {}, $class;
124			my $fb = shift;
125			$self->_init (@_);
126			push @{$self->{comment}}, $self->Message::Util::comment_to_array ($fb);
127			$fb =~ s/[^0-9.-]//g;
128			$self->{value} = $& if $fb =~ /-?[0-9]+(\.[0-9]+)?/;
129	wakaba	1.1	$self;
130			}
131
132	wakaba	1.2	=back
133
134			=head1 METHODS FOR FIELD BODY VALUE
135
136			=over 4
137
138			=item $self->value ([$new_value])
139	wakaba	1.1
140			Returns or set value. Note that this method
141			does not check whether value is valid or not.
142
143	wakaba	1.2	=item $self->value_formatted ()
144	wakaba	1.1
145			Returns formatted value string. Note that this method
146			does not check whether value is valid or not.
147			To check min/max value, use C<stringify> with
148			C<output_comment = -1> option (if necessary).
149
150			=cut
151
152			sub value ($;$%) {
153			my $self = shift;
154			my $new_value = shift;
155			if ($new_value) {
156			$self->{value} = $new_value;
157			}
158			$self->{value};
159			}
160
161			sub value_formatted ($;%) {
162			my $self = shift;
163			my %option = @_;
164			$option{format_pattern} = $self->{option}->{format_pattern}
165			unless defined $option{format_pattern};
166			sprintf $option{format_pattern}, $self->{value};
167			}
168
169	wakaba	1.2	=item $self->comment ()
170
171			Returns array reference of comments. You can add/remove/change
172			array values.
173
174			=cut
175
176			sub comment ($) {
177			my $self = shift;
178			$self->{comment};
179			}
180
181			=item $self->comment_add ($comment, [%option]
182	wakaba	1.1
183			Adds a C<comment>. Comments are outputed only when
184			the class option (not an option of this method!)
185			C<output_comment> is enabled (value C<1>).
186
187			On this method, only one option, C<prepend> is available.
188			With this option, additional comment is prepend
189			to current comments. (Default value is C<-1>, append.)
190
191			=cut
192
193			sub comment_add ($$;%) {
194			my $self = shift;
195			my ($value, %option) = (shift, @_);
196			if ($option{prepend}) {
197			unshift @{$self->{comment}}, $value;
198			} else {
199			push @{$self->{comment}}, $value;
200			}
201			$self;
202			}
203
204	wakaba	1.2	=item $self->stringify ()
205	wakaba	1.1
206			Returns C<field-body> as a string.
207
208			=cut
209
210			sub stringify ($;%) {
211			my $self = shift;
212			my %option = @_;
213	wakaba	1.2	for (qw(check_max check_min output_comment value_max value_min value_if_invalid)) {
214			$option{$_} \|\|= $self->{option}->{$_};
215			}
216	wakaba	1.1	$option{format_pattern} = $self->{option}->{format_pattern}
217			unless defined $option{format_pattern};
218			return $option{value_if_invalid}
219	wakaba	1.2	if $option{check_max} && $option{value_max} < $self->{value};
220	wakaba	1.1	return $option{value_if_invalid}
221	wakaba	1.2	if $option{check_min} && $option{value_min} > $self->{value};
222	wakaba	1.1	my $s = sprintf $option{format_pattern}, $self->{value};
223	wakaba	1.2	if ($option{output_comment}) {
224	wakaba	1.1	for (@{$self->{comment}}) {
225	wakaba	1.2	my $t = $self->Message::Util::encode_ccontent ($_);
226			$s .= ' ('.$t.')' if length $t;
227	wakaba	1.1	}
228			}
229			$s;
230			}
231	wakaba	1.2	*as_string = \&stringify;
232
233			=back
234	wakaba	1.1
235	wakaba	1.2	=over 4
236
237			=item $self->option ( $option-name / $option-name, $option-value, ...)
238
239			Set/gets option value(s). You can pass multiple option name-value pair
240			as parameter when setting.
241
242			=cut
243
244			## Inherited
245
246			=item $self->clone ()
247
248			Returns a copy of the object.
249
250			=cut
251
252			## Inherited
253
254			=back
255	wakaba	1.1
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	wakaba	1.3	$Date: 2002/04/05 14:55:28 $
279	wakaba	1.1
280			=cut
281
282			1;