Message/Field/Numval.pm


=head1 NAME

Message::Field::Numval Perl module

=head1 DESCRIPTION

Perl module for RFC 2822 style C<field-body>'es,
which takes numeric value.

=cut

package Message::Field::Numval;
require 5.6.0;
use strict;
use re 'eval';
use vars qw(%DEFAULT %REG $VERSION);
$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
require Message::Util;
use overload '""' => sub {shift->stringify};

$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*\x29/;
$REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]|(??{$REG{comment}}))*)\x29/;

%DEFAULT = (
  check_max     => -1,
  check_min     => 1,
  encoding_after_encode => '*default',
  encoding_before_decode        => '*default',
  field_name    => 'lines',
  format_pattern        => '%d',
  hook_encode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::encode_header_string,
  hook_decode_string    => #sub {shift; (value => shift, @_)},
        \&Message::Util::decode_header_string,
  output_comment        => -1,
  value_default => 0,
  value_if_invalid      => '',
  value_max     => 100,
  value_min     => 0,
);

## Initialization for both C<new ()> and C<parse ()> methods.
sub _initialize ($;%) {
  my $self = shift;
  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}->{check_max} = 1;
    $self->{option}->{value_min} = 1;
  }
  $self;
}

=head2 Message::Field::Numval->new ()

Return empty Message::Field::Numval object.

=cut

sub new ($;%) {
  my $class = shift;
  my $self = bless {comment => [], option => {@_}}, $class;
  $self->_initialize ();
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self->{value} = $self->{option}->{value_default};
  $self->{value} = $DEFAULT{value_default} unless defined $self->{value};
  $self;
}

=head2 Message::Field::Numval->parse ($unfolded_field_body)

Parses C<field-body> consist of a numeric value.

=cut

sub parse ($$;%) {
  my $class = shift;
  my $field_body = shift;
  my $self = bless {comment => [], option => {@_}}, $class;
  $self->_initialize ();
  for (keys %DEFAULT) {$self->{option}->{$_} ||= $DEFAULT{$_}}
  $self->{option}->{value_default} = $DEFAULT{value_default}
    unless defined $self->{option}->{value_default};
  $field_body =~ s{$REG{M_comment}}{
      my $comment = $self->_decode_ccontent ($1);
      push @{$self->{comment}}, $comment if $comment;
    '';
  }goex;
  $field_body =~ s/[^0-9.-]//g;
  $self->{value} = $& if $field_body =~ /-?[0-9]+(\.[0-9]+)?/;
  $self->{value} = $self->{option}->{value_default} unless defined $self->{value};
  $self;
}

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

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

=head2 $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};
}

=head2 $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;
}

=head2 $self->comment ()

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

=cut

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

=head2 $self->stringify ()

Returns C<field-body> as a string.

=cut

sub stringify ($;%) {
  my $self = shift;
  my %option = @_;
  $option{check_max} ||= $self->{option}->{check_max};
  $option{check_min} ||= $self->{option}->{check_min};
  $option{output_comment} ||= $self->{option}->{output_comment};
  $option{format_pattern} = $self->{option}->{format_pattern}
    unless defined $option{format_pattern};
  $option{value_max} ||= $self->{option}->{value_max};
  $option{value_min} ||= $self->{option}->{value_min};
  $option{value_if_invalid} ||= $self->{option}->{value_if_invalid};
  return $option{value_if_invalid}
    if $option{check_max}>0 && $option{value_max}<$self->{value};
  return $option{value_if_invalid}
    if $option{check_min}>0 && $option{value_min}>$self->{value};
  my $s = sprintf $option{format_pattern}, $self->{value};
  if ($option{output_comment}>0) {
    for (@{$self->{comment}}) {
      my %f = &{$self->{option}->{hook_encode_string}} ($self, 
         $_, type => 'ccontent');
      $f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/
        "\x5C$1".(defined $2?"\x5C$2":'')/ge;
      $s .= ' ('.$f{value}.')' if defined $f{value};
    }
  }
  $s;
}

sub _decode_ccontent ($$) {
  require Message::MIME::EncodedWord;
  &Message::MIME::EncodedWord::decode_ccontent (@_[1,0]);
}

=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>.

=cut

1;
1	wakaba	1.1
2			=head1 NAME
3
4			Message::Field::Numval Perl module
5
6			=head1 DESCRIPTION
7
8			Perl module for RFC 2822 style C<field-body>'es,
9			which takes numeric value.
10
11			=cut
12
13			package Message::Field::Numval;
14			require 5.6.0;
15			use strict;
16			use re 'eval';
17			use vars qw(%DEFAULT %REG $VERSION);
18			$VERSION=do{my @r=(q$Revision: 1.3 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
19			require Message::Util;
20			use overload '""' => sub {shift->stringify};
21
22			$REG{comment} = qr/\x28(?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*\x29/;
23			$REG{M_comment} = qr/\x28((?:\x5C[\x00-\xFF]\|[\x00-\x0C\x0E-\x27\x2A-\x5B\x5D-\xFF]\|(??{$REG{comment}}))*)\x29/;
24
25			%DEFAULT = (
26			check_max => -1,
27			check_min => 1,
28			encoding_after_encode => '*default',
29			encoding_before_decode => '*default',
30			field_name => 'lines',
31			format_pattern => '%d',
32			hook_encode_string => #sub {shift; (value => shift, @_)},
33			\&Message::Util::encode_header_string,
34			hook_decode_string => #sub {shift; (value => shift, @_)},
35			\&Message::Util::decode_header_string,
36			output_comment => -1,
37			value_default => 0,
38			value_if_invalid => '',
39			value_max => 100,
40			value_min => 0,
41			);
42
43			## Initialization for both C<new ()> and C<parse ()> methods.
44			sub _initialize ($;%) {
45			my $self = shift;
46			my $fname = lc $self->{option}->{field_name};
47			if ($fname eq 'mime-version') {
48			$self->{option}->{output_comment} = 1;
49			$self->{option}->{format_pattern} = '%1.1f';
50			$self->{option}->{check_max} = 1;
51			$self->{option}->{value_min} = 1;
52			}
53			$self;
54			}
55
56			=head2 Message::Field::Numval->new ()
57
58			Return empty Message::Field::Numval object.
59
60			=cut
61
62			sub new ($;%) {
63			my $class = shift;
64			my $self = bless {comment => [], option => {@_}}, $class;
65			$self->_initialize ();
66			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
67			$self->{value} = $self->{option}->{value_default};
68			$self->{value} = $DEFAULT{value_default} unless defined $self->{value};
69			$self;
70			}
71
72			=head2 Message::Field::Numval->parse ($unfolded_field_body)
73
74			Parses C<field-body> consist of a numeric value.
75
76			=cut
77
78			sub parse ($$;%) {
79			my $class = shift;
80			my $field_body = shift;
81			my $self = bless {comment => [], option => {@_}}, $class;
82			$self->_initialize ();
83			for (keys %DEFAULT) {$self->{option}->{$_} \|\|= $DEFAULT{$_}}
84			$self->{option}->{value_default} = $DEFAULT{value_default}
85			unless defined $self->{option}->{value_default};
86			$field_body =~ s{$REG{M_comment}}{
87			my $comment = $self->_decode_ccontent ($1);
88			push @{$self->{comment}}, $comment if $comment;
89			'';
90			}goex;
91			$field_body =~ s/[^0-9.-]//g;
92			$self->{value} = $& if $field_body =~ /-?[0-9]+(\.[0-9]+)?/;
93			$self->{value} = $self->{option}->{value_default} unless defined $self->{value};
94			$self;
95			}
96
97			=head2 $self->value ([$new_value])
98
99			Returns or set value. Note that this method
100			does not check whether value is valid or not.
101
102			=head2 $self->value_formatted ()
103
104			Returns formatted value string. Note that this method
105			does not check whether value is valid or not.
106			To check min/max value, use C<stringify> with
107			C<output_comment = -1> option (if necessary).
108
109			=cut
110
111			sub value ($;$%) {
112			my $self = shift;
113			my $new_value = shift;
114			if ($new_value) {
115			$self->{value} = $new_value;
116			}
117			$self->{value};
118			}
119
120			sub value_formatted ($;%) {
121			my $self = shift;
122			my %option = @_;
123			$option{format_pattern} = $self->{option}->{format_pattern}
124			unless defined $option{format_pattern};
125			sprintf $option{format_pattern}, $self->{value};
126			}
127
128			=head2 $self->comment_add ($comment, [%option]
129
130			Adds a C<comment>. Comments are outputed only when
131			the class option (not an option of this method!)
132			C<output_comment> is enabled (value C<1>).
133
134			On this method, only one option, C<prepend> is available.
135			With this option, additional comment is prepend
136			to current comments. (Default value is C<-1>, append.)
137
138			=cut
139
140			sub comment_add ($$;%) {
141			my $self = shift;
142			my ($value, %option) = (shift, @_);
143			if ($option{prepend}) {
144			unshift @{$self->{comment}}, $value;
145			} else {
146			push @{$self->{comment}}, $value;
147			}
148			$self;
149			}
150
151			=head2 $self->comment ()
152
153			Returns array reference of comments. You can add/remove/change
154			array values.
155
156			=cut
157
158			sub comment ($) {
159			my $self = shift;
160			$self->{comment};
161			}
162
163			=head2 $self->stringify ()
164
165			Returns C<field-body> as a string.
166
167			=cut
168
169			sub stringify ($;%) {
170			my $self = shift;
171			my %option = @_;
172			$option{check_max} \|\|= $self->{option}->{check_max};
173			$option{check_min} \|\|= $self->{option}->{check_min};
174			$option{output_comment} \|\|= $self->{option}->{output_comment};
175			$option{format_pattern} = $self->{option}->{format_pattern}
176			unless defined $option{format_pattern};
177			$option{value_max} \|\|= $self->{option}->{value_max};
178			$option{value_min} \|\|= $self->{option}->{value_min};
179			$option{value_if_invalid} \|\|= $self->{option}->{value_if_invalid};
180			return $option{value_if_invalid}
181			if $option{check_max}>0 && $option{value_max}<$self->{value};
182			return $option{value_if_invalid}
183			if $option{check_min}>0 && $option{value_min}>$self->{value};
184			my $s = sprintf $option{format_pattern}, $self->{value};
185			if ($option{output_comment}>0) {
186			for (@{$self->{comment}}) {
187			my %f = &{$self->{option}->{hook_encode_string}} ($self,
188			$_, type => 'ccontent');
189			$f{value} =~ s/([\x28\x29\x5C])([\x21-\x7E])?/
190			"\x5C$1".(defined $2?"\x5C$2":'')/ge;
191			$s .= ' ('.$f{value}.')' if defined $f{value};
192			}
193			}
194			$s;
195			}
196
197			sub _decode_ccontent ($$) {
198			require Message::MIME::EncodedWord;
199			&Message::MIME::EncodedWord::decode_ccontent (@_[1,0]);
200			}
201
202			=head1 LICENSE
203
204			Copyright 2002 wakaba E<lt>w@suika.fam.cxE<gt>.
205
206			This program is free software; you can redistribute it and/or modify
207			it under the terms of the GNU General Public License as published by
208			the Free Software Foundation; either version 2 of the License, or
209			(at your option) any later version.
210
211			This program is distributed in the hope that it will be useful,
212			but WITHOUT ANY WARRANTY; without even the implied warranty of
213			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
214			GNU General Public License for more details.
215
216			You should have received a copy of the GNU General Public License
217			along with this program; see the file COPYING. If not, write to
218			the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
219			Boston, MA 02111-1307, USA.
220
221			=head1 CHANGE
222
223			See F<ChangeLog>.
224
225			=cut
226
227			1;