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.1 $=~/\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+' => 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: $

=cut

1;
1
2	=head1 NAME
3
4	Message::Field::Numval -- Perl module for
5	Internet message header field body that takes numeric values
6
7	=cut
8
9	package Message::Field::Numval;
10	use strict;
11	use vars qw(@ISA $VERSION);
12	$VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
13	require Message::Util;
14	require Message::Field::Structured;
15	push @ISA, qw(Message::Field::Structured);
16	use overload '.=' => sub { $_[0]->comment_add ($_[1]) },
17	'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
55	The following methods construct new C<Message::Field::Numval> objects:
56
57	=over 4
58
59	=cut
60
61	## Initialize of this class -- called by constructors
62	sub _init ($;%) {
63	my $self = shift;
64	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	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	$self->{option}->{value_min} = 1;
91	} elsif ($fname eq 'x-priority' \|\| $fname eq 'x-jsmail-priority') {
92	$self->{option}->{output_comment} = 1;
93	$self->{option}->{check_max} = 1;
94	$self->{option}->{check_min} = 1;
95	$self->{option}->{value_min} = 1; ## Highest
96	$self->{option}->{value_max} = 5; ## some implemention uses larger number...
97	}
98	}
99
100	=item Message::Field::Numval->new ([%options])
101
102	Constructs a new C<Message::Field::Numval> object. You might pass some
103	options as parameters to the constructor.
104
105	=cut
106
107	sub new ($;%) {
108	my $class = shift;
109	my $self = bless {}, $class;
110	$self->_init (@_);
111	$self;
112	}
113
114	=item Message::Field::Numval->parse ($field-body, [%options])
115
116	Constructs a new C<Message::Field::Numval> object with
117	given field body. You might pass some options as parameters to the constructor.
118
119	=cut
120
121	sub parse ($$;%) {
122	my $class = shift;
123	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	$self;
130	}
131
132	=back
133
134	=head1 METHODS FOR FIELD BODY VALUE
135
136	=over 4
137
138	=item $self->value ([$new_value])
139
140	Returns or set value. Note that this method
141	does not check whether value is valid or not.
142
143	=item $self->value_formatted ()
144
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	=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
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	=item $self->stringify ()
205
206	Returns C<field-body> as a string.
207
208	=cut
209
210	sub stringify ($;%) {
211	my $self = shift;
212	my %option = @_;
213	for (qw(check_max check_min output_comment value_max value_min value_if_invalid)) {
214	$option{$_} \|\|= $self->{option}->{$_};
215	}
216	$option{format_pattern} = $self->{option}->{format_pattern}
217	unless defined $option{format_pattern};
218	return $option{value_if_invalid}
219	if $option{check_max} && $option{value_max} < $self->{value};
220	return $option{value_if_invalid}
221	if $option{check_min} && $option{value_min} > $self->{value};
222	my $s = sprintf $option{format_pattern}, $self->{value};
223	if ($option{output_comment}) {
224	for (@{$self->{comment}}) {
225	my $t = $self->Message::Util::encode_ccontent ($_);
226	$s .= ' ('.$t.')' if length $t;
227	}
228	}
229	$s;
230	}
231	*as_string = \&stringify;
232
233	=back
234
235	=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
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: $
279
280	=cut
281
282	1;