File Coverage

blib/lib/Number/Tolerant.pm
Criterion Covered Total %
statement 115 116 99.1
branch 85 88 96.5
condition 61 72 84.7
subroutine 31 31 100.0
pod 10 10 100.0
total 302 317 95.2


line stmt bran cond sub pod time code
1 26     26   539720 use strict;
  26         62  
  26         660  
2 26     26   130 use warnings;
  26         48  
  26         1313  
3             package Number::Tolerant;
4             # ABSTRACT: tolerance ranges for inexact numbers
5             $Number::Tolerant::VERSION = '1.708';
6 26     26   20019 use Sub::Exporter::Util;
  26         431325  
  26         243  
7 26         169 use Sub::Exporter 0.950 -setup => {
8             exports => { tolerance => Sub::Exporter::Util::curry_class('new'), },
9             groups => { default => [ qw(tolerance) ] },
10 26     26   4990 };
  26         490  
11              
12 26     26   10363 use Carp ();
  26         53  
  26         416  
13 26     26   132 use Scalar::Util ();
  26         52  
  26         50970  
14              
15             #pod =head1 SYNOPSIS
16             #pod
17             #pod use Number::Tolerant;
18             #pod
19             #pod my $range = tolerance(10 => to => 12);
20             #pod my $random = 10 + rand(2);
21             #pod
22             #pod die "I shouldn't die" unless $random == $range;
23             #pod
24             #pod print "This line will always print.\n";
25             #pod
26             #pod =head1 DESCRIPTION
27             #pod
28             #pod Number::Tolerant creates a number-like object whose value refers to a range of
29             #pod possible values, each equally acceptable. It overloads comparison operations
30             #pod to reflect this.
31             #pod
32             #pod I use this module to simplify the comparison of measurement results to
33             #pod specified tolerances.
34             #pod
35             #pod reject $product unless $measurement == $specification;
36             #pod
37             #pod =head1 METHODS
38             #pod
39             #pod =head2 Instantiation
40             #pod
41             #pod =head3 new
42             #pod
43             #pod =head3 tolerance
44             #pod
45             #pod There is a C method on the Number::Tolerant class, but it also exports a
46             #pod simple function, C, which will return an object of the
47             #pod Number::Tolerant class. Both use the same syntax:
48             #pod
49             #pod my $range = Number::Tolerant->new( $x => $method => $y);
50             #pod
51             #pod my $range = tolerance( $x => $method => $y);
52             #pod
53             #pod The meaning of C<$x> and C<$y> are dependent on the value of C<$method>, which
54             #pod describes the nature of the tolerance. Tolerances can be defined in five ways,
55             #pod at present:
56             #pod
57             #pod method range
58             #pod -------------------+------------------
59             #pod plus_or_minus | x +/- y
60             #pod plus_or_minus_pct | x +/- (y% of x)
61             #pod or_more | x to Inf
62             #pod or_less | x to -Inf
63             #pod more_than | x to Inf, not x
64             #pod less_than | x to -Inf, not x
65             #pod to | x to y
66             #pod infinite | -Inf to Inf
67             #pod offset | (x + y1) to (x + y2)
68             #pod
69             #pod For C and C, C<$y> is ignored if passed. For C,
70             #pod neither C<$x> nor C<$y> is used; "infinite" should be the sole argument. The
71             #pod first two arguments can be reversed for C and C, to be
72             #pod more English-like.
73             #pod
74             #pod Offset tolerances are slightly unusual. Here is an example:
75             #pod
76             #pod my $offset_tolerance = tolerance(10 => offset => (-3, 5));
77             #pod # stringifies to: 10 (-3 +5)
78             #pod
79             #pod An offset is very much like a C tolerance, but its center value
80             #pod is not necessarily the midpoint between its extremes. This is significant for
81             #pod comparisons and numifications of the tolerance. Given the following two
82             #pod tolerances:
83             #pod
84             #pod my $pm_dice = tolerance(10.5 => plus_or_minus => 7.5);
85             #pod my $os_dice = tolerance(11 => offset => (-8, 7));
86             #pod
87             #pod The first will sort as numerically less than the second.
88             #pod
89             #pod If the given arguments can't be formed into a tolerance, an exception will be
90             #pod raised.
91             #pod
92             #pod =cut
93              
94             # these are the default plugins
95             my %_plugins;
96              
97             sub _plugins {
98 138     138   551 keys %_plugins
99             }
100              
101             sub disable_plugin {
102 2     2 1 69 my ($class, $plugin) = @_;
103 2         9 $class->_boot_up;
104 2         7 delete $_plugins{ $plugin };
105 2         8 return;
106             }
107              
108             sub enable_plugin {
109 265     265 1 1235 my ($class, $plugin) = @_;
110 265         680 $class->_boot_up;
111              
112             # XXX: there has to be a better test to use here -- rjbs, 2006-01-27
113 265 100       357 unless (eval { $plugin->can('construct') }) {
  265         2425  
114 262 100       16094 eval "require $plugin" or die $@;
115             }
116              
117 264 100       923 unless (eval { $class->validate_plugin($plugin); }) {
  264         1294  
118 1         150 Carp::croak "class $plugin is not a valid Number::Tolerant plugin: $@";
119             }
120              
121 263         642 $_plugins{ $plugin } = undef;
122 263         3327 return;
123             }
124              
125             sub validate_plugin {
126 264     264 1 528 my ($class, $plugin) = @_;
127 264         644 for (qw(parse valid_args construct)) {
128 790 100       5202 die "can't $_" unless $plugin->can($_);
129             }
130 263         984 return 1;
131             }
132              
133             my $booted;
134             sub _boot_up {
135 440 100   440   1249 return if $booted;
136 26         57 $booted = 1;
137             my @_default_plugins =
138 26         90 map { "Number::Tolerant::Type::$_" }
  260         618  
139             qw(
140             constant infinite less_than
141             more_than offset or_less
142             or_more plus_or_minus plus_or_minus_pct
143             to
144             );
145              
146 26         217 __PACKAGE__->enable_plugin($_) for @_default_plugins;
147             }
148              
149             sub new {
150 139     139 1 20884 my $class = shift;
151 139         424 $class->_boot_up;
152 139 100       367 return unless @_;
153 138         180 my $self;
154              
155 138         400 for my $type ($class->_plugins) {
156 853 100       2867 next unless my @args = $type->valid_args(@_);
157 115         525 my $guts = $type->construct(@args);
158              
159 115 100 66     2724 return $guts unless ref $guts and not Scalar::Util::blessed($guts);
160              
161 111 100 100     821 if (
      100        
      100        
162             defined $guts->{min} and defined $guts->{max} and
163             $guts->{min} == $guts->{max} and
164             not $guts->{constant}
165             ) {
166 3         10 @_ = ($class, $guts->{min});
167 3         18 goto &new;
168             }
169 108         639 $self = { method => $type, %$guts };
170 108         392 last;
171             }
172              
173 131 100       4510 Carp::confess("couldn't form tolerance from given args") unless $self;
174 108         554 bless $self => $self->{method};
175             }
176              
177             #pod =head3 from_string
178             #pod
179             #pod A new tolerance can be instantiated from the stringification of an old
180             #pod tolerance. For example:
181             #pod
182             #pod my $range = Number::Tolerant->from_string("10 to 12");
183             #pod
184             #pod die "Everything's OK!" if 11 == $range; # program dies of joy
185             #pod
186             #pod This will I yet parse stringified unions, but that will be implemented in
187             #pod the future. (I just don't need it yet.)
188             #pod
189             #pod If a string can't be parsed, an exception is raised.
190             #pod
191             #pod =cut
192              
193             sub from_string {
194 34     34 1 6771 my ($class, $string) = @_;
195 34         157 $class->_boot_up;
196 34 100       229 Carp::croak "from_string is a class method" if ref $class;
197 33         155 for my $type (keys %_plugins) {
198 211 100       904 if (defined(my $tolerance = $type->parse($string, $class))) {
199 29         106 return $tolerance;
200             }
201             }
202              
203 4         765 Carp::confess("couldn't form tolerance from given string");
204             }
205              
206             sub stringify {
207 53     53 1 22004 my ($self) = @_;
208              
209 53 100 100     603 return 'any number' unless (defined $self->{min} || defined $self->{max});
210              
211 49         80 my $string = '';
212              
213 49 100       133 if (defined $self->{min}) {
214 37 100       186 $string .= "$self->{min} <" . ($self->{exclude_min} ? q{} : '=') . q{ };
215             }
216              
217 49         98 $string .= 'x';
218              
219 49 100       134 if (defined $self->{max}) {
220 33 100       133 $string .= ' <' . ($self->{exclude_max} ? q{} : '=') . " $self->{max}";
221             }
222              
223 49         686 return $string;
224             }
225              
226             #pod =head2 stringify_as
227             #pod
228             #pod my $string = $tolerance->stringify_as($type);
229             #pod
230             #pod This method does nothing! Someday, it will stringify the given tolerance as a
231             #pod different type, if possible. "10 +/- 1" will
232             #pod C to "10 +/- 10%" for example.
233             #pod
234             #pod =cut
235              
236       2 1   sub stringify_as { }
237              
238             #pod =head2 numify
239             #pod
240             #pod my $n = $tolerance->numify;
241             #pod
242             #pod This returns the numeric form of a tolerance. If a tolerance has both a
243             #pod minimum and a maximum, and they are the same, then that is the numification.
244             #pod Otherwise, numify returns undef.
245             #pod
246             #pod =cut
247              
248             sub numify {
249             # if a tolerance has equal min and max, it numifies to that number
250             return $_[0]{min}
251 3 50 66 3 1 25 if $_[0]{min} and $_[0]{max} and $_[0]{min} == $_[0]{max};
      66        
252             ## no critic (ReturnUndef)
253 3         12 return undef;
254             }
255              
256 454   100 454   2424 sub _num_eq { not( _num_gt($_[0],$_[1]) or _num_lt($_[0],$_[1]) ) }
257              
258 86     86   1291 sub _num_ne { not _num_eq(@_) }
259              
260 672 100   672   2260 sub _num_gt { $_[2] ? goto &_num_lt_canonical : goto &_num_gt_canonical }
261              
262 556 100   556   2719 sub _num_lt { $_[2] ? goto &_num_gt_canonical : goto &_num_lt_canonical }
263              
264 50 100   50   133 sub _num_gte { $_[1] == $_[0] ? 1 : goto &_num_gt; }
265              
266 50 100   50   134 sub _num_lte { $_[1] == $_[0] ? 1 : goto &_num_lt; }
267              
268             sub _num_gt_canonical {
269 663 100 100 663   2579 return 1 if $_[0]{exclude_min} and $_[0]{min} == $_[1];
270             defined $_[0]->{min} ? $_[1] < $_[0]->{min} : undef
271 635 100       3795 }
272              
273             sub _num_lt_canonical {
274 565 100 100 565   1901 return 1 if $_[0]{exclude_max} and $_[0]{max} == $_[1];
275             defined $_[0]->{max} ? $_[1] > $_[0]->{max} : undef
276 551 100       3762 }
277              
278 8     8   5134 sub _union { $_[0]->union($_[1]); }
279              
280             sub union {
281 8     8 1 728 require Number::Tolerant::Union;
282 8         41 return Number::Tolerant::Union->new($_[0],$_[1]);
283             }
284              
285 24     24   15683 sub _intersection { $_[0]->intersection($_[1]); }
286              
287             sub intersection {
288 24 100   24 1 74 if (! ref $_[1]) {
289 6 100       22 return $_[1] if $_[0] == $_[1];
290 1         6 Carp::confess "no valid intersection of ($_[0]) and ($_[1])";
291             }
292              
293 18         24 my ($min, $max);
294 0         0 my ($exclude_min, $exclude_max);
295              
296 18 100 100     275 if (defined $_[0]->{min} and defined $_[1]->{min}) {
297 8         30 ($min) = sort {$b<=>$a} ($_[0]->{min}, $_[1]->{min});
  8         27  
298             } else {
299 10 100       106 $min = defined $_[0]->{min} ? $_[0]->{min} : $_[1]->{min};
300             }
301              
302             $exclude_min = 1
303             if ($_[0]{min} and $min == $_[0]{min} and $_[0]{exclude_min})
304 18 100 100     174 or ($_[1]{min} and $min == $_[1]{min} and $_[1]{exclude_min});
      66        
      100        
      66        
      66        
305              
306 18 100 100     108 if (defined $_[0]->{max} and defined $_[1]->{max}) {
307 8         23 ($max) = sort {$a<=>$b} ($_[0]->{max}, $_[1]->{max});
  8         25  
308             } else {
309 10 100       27 $max = defined $_[0]->{max} ? $_[0]->{max} : $_[1]->{max};
310             }
311              
312             $exclude_max = 1
313             if ($_[0]{max} and $max == $_[0]{max} and $_[0]{exclude_max})
314 18 100 100     173 or ($_[1]{max} and $max == $_[1]{max} and $_[1]{exclude_max});
      66        
      100        
      66        
      66        
315              
316 18 100 100     104 return $_[0]->new('infinite') unless defined $min || defined $max;
317              
318 17 100       52 return $_[0]->new($min => ($exclude_min ? 'more_than' : 'or_more'))
    100          
319             unless defined $max;
320              
321 13 100       40 return $_[0]->new($max => ($exclude_max ? 'less_than' : 'or_less'))
    100          
322             unless defined $min;
323              
324 10 50 33     54 Carp::confess "no valid intersection of ($_[0]) and ($_[1])"
325             if $max < $min or $min > $max;
326              
327 10         63 bless {
328             max => $max,
329             min => $min,
330             exclude_max => $exclude_max,
331             exclude_min => $exclude_min
332             } => 'Number::Tolerant::Type::to';
333             }
334              
335             #pod =head2 Overloading
336             #pod
337             #pod Tolerances overload a few operations, mostly comparisons.
338             #pod
339             #pod =over
340             #pod
341             #pod =item boolean
342             #pod
343             #pod Tolerances are always true.
344             #pod
345             #pod =item numify
346             #pod
347             #pod Most tolerances numify to undef; see C>.
348             #pod
349             #pod =item stringify
350             #pod
351             #pod A tolerance stringifies to a short description of itself, generally something
352             #pod like "m < x < n"
353             #pod
354             #pod infinite - "any number"
355             #pod to - "m <= x <= n"
356             #pod or_more - "m <= x"
357             #pod or_less - "x <= n"
358             #pod more_than - "m < x"
359             #pod less_than - "x < n"
360             #pod offset - "x (-y1 +y2)"
361             #pod constant - "x"
362             #pod plus_or_minus - "x +/- y"
363             #pod plus_or_minus_pct - "x +/- y%"
364             #pod
365             #pod =item equality
366             #pod
367             #pod A number is equal to a tolerance if it is neither less than nor greater than
368             #pod it. (See below).
369             #pod
370             #pod =item smart match
371             #pod
372             #pod Same as equality.
373             #pod
374             #pod =item comparison
375             #pod
376             #pod A number is greater than a tolerance if it is greater than its maximum value.
377             #pod
378             #pod A number is less than a tolerance if it is less than its minimum value.
379             #pod
380             #pod No number is greater than an "or_more" tolerance or less than an "or_less"
381             #pod tolerance.
382             #pod
383             #pod "...or equal to" comparisons include the min/max values in the permissible
384             #pod range, as common sense suggests.
385             #pod
386             #pod =item tolerance intersection
387             #pod
388             #pod A tolerance C<&> a tolerance or number is the intersection of the two ranges.
389             #pod Intersections allow you to quickly narrow down a set of tolerances to the most
390             #pod stringent intersection of values.
391             #pod
392             #pod tolerance(5 => to => 6) & tolerance(5.5 => to => 6.5);
393             #pod # this yields: tolerance(5.5 => to => 6)
394             #pod
395             #pod If the given values have no intersection, C<()> is returned.
396             #pod
397             #pod An intersection with a normal number will yield that number, if it is within
398             #pod the tolerance.
399             #pod
400             #pod =item tolerance union
401             #pod
402             #pod A tolerance C<|> a tolerance or number is the union of the two. Unions allow
403             #pod multiple tolerances, whether they intersect or not, to be treated as one. See
404             #pod L for more information.
405             #pod
406             #pod =cut
407              
408             use overload
409             fallback => 1,
410 10     10   1383 'bool' => sub { 1 },
411             '0+' => 'numify',
412             '<=>' => sub {
413 90 50   90   245 my $rv = $_[0] == $_[1] ? 0
    100          
    100          
414             : $_[0] < $_[1] ? -1
415             : $_[0] > $_[1] ? 1
416             : die "impossible";
417 90 100       297 $rv *= -1 if $_[2];
418 90         422 return $rv;
419             },
420 26         322 '""' => 'stringify',
421             '==' => '_num_eq',
422             '~~' => '_num_eq',
423             '!=' => '_num_ne',
424             '>' => '_num_gt',
425             '<' => '_num_lt',
426             '>=' => '_num_gte',
427             '<=' => '_num_lte',
428             '|' => '_union',
429 26     26   157 '&' => '_intersection';
  26         50  
430              
431             #pod =back
432             #pod
433             #pod =head1 EXTENDING
434             #pod
435             #pod This feature is slighly experimental, but it's here.
436             #pod
437             #pod New tolerance types may be written as subclasses of L,
438             #pod providing the interface described in its documentation. They can then be
439             #pod enabled or disabled with the following methods:
440             #pod
441             #pod =head2 C< enable_plugin >
442             #pod
443             #pod Number::Tolerant->enable_plugin($class_name);
444             #pod
445             #pod This method enables the named class, so that attempts to create new tolerances
446             #pod will check against this class. Classes are checked against
447             #pod C> before being enabled. An exception is thrown if the
448             #pod class does not appear to provide the Number::Tolerant::Type interface.
449             #pod
450             #pod =head2 C< disable_plugin >
451             #pod
452             #pod Number::Tolerant->disable_plugin($class_name);
453             #pod
454             #pod This method will disable the named class, so that future attempts to create new
455             #pod tolerances will not check against this class.
456             #pod
457             #pod =head2 C< validate_plugin >
458             #pod
459             #pod Number::Tolerant->validate_plugin($class_name);
460             #pod
461             #pod This method checks (naively) that the given class provides the interface
462             #pod defined in Number::Tolerant::Type. If it does not, an exception is thrown.
463             #pod
464             #pod =head1 TODO
465             #pod
466             #pod =over 4
467             #pod
468             #pod =item * Extend C to cover unions.
469             #pod
470             #pod =item * Extend C to include Number::Range-type specifications.
471             #pod
472             #pod =item * Allow translation into forms not originally used:
473             #pod
474             #pod my $range = tolerance(9 => to => 17);
475             #pod my $range_pm = $range->convert_to('plus_minus');
476             #pod $range->stringify_as('plus_minus_pct');
477             #pod
478             #pod =item * Create a factory so that you can simultaneously work with two sets of plugins.
479             #pod
480             #pod This one is very near completion. There will now be two classes that should be
481             #pod used: Number::Tolerant::Factory, which produces tolerances, and
482             #pod Number::Tolerant::Tolerance, which is a tolerance. Both will inherit from
483             #pod N::T, for supporting old code, and N::T will dispatch construction methods to a
484             #pod default factory.
485             #pod
486             #pod =back
487             #pod
488             #pod =head1 SEE ALSO
489             #pod
490             #pod The module L provides another way to deal with ranges of
491             #pod numbers. The major differences are: N::R is set-like, not range-like; N::R
492             #pod does not overload any operators. Number::Tolerant will not (like N::R) attempt
493             #pod to parse a textual range specification like "1..2,5,7..10" unless specifically
494             #pod instructed to. (The valid formats for strings passed to C does
495             #pod not match Number::Range exactly. See TODO.)
496             #pod
497             #pod The C code:
498             #pod
499             #pod $range = Number::Range->new("10..15","20..25");
500             #pod
501             #pod Is equivalent to the C code:
502             #pod
503             #pod $range = Number::Tolerant::Union->new(10..15,20..25);
504             #pod
505             #pod ...while the following code expresses an actual range:
506             #pod
507             #pod $range = tolerance(10 => to => 15) | tolerance(20 => to => 25);
508             #pod
509             #pod =head1 THANKS
510             #pod
511             #pod Thanks to Yuval Kogman and #perl-qa for helping find the bizarre bug that drove
512             #pod the minimum required perl up to 5.8
513             #pod
514             #pod Thanks to Tom Freedman, who reminded me that this code was fun to work on, and
515             #pod also provided the initial implementation for the offset type.
516             #pod
517             #pod =cut
518              
519             "1 +/- 0";
520              
521             __END__