File Coverage

blib/lib/Number/Tolerant.pm
Criterion Covered Total %
statement 116 116 100.0
branch 85 88 96.5
condition 68 72 94.4
subroutine 31 31 100.0
pod 10 10 100.0
total 310 317 97.7


line stmt bran cond sub pod time code
1 26     26   1330272 use strict;
  26         251  
  26         555  
2 26     26   98 use warnings;
  26         44  
  26         1044  
3             package Number::Tolerant 1.709;
4             # ABSTRACT: tolerance ranges for inexact numbers
5              
6 26     26   9098 use Sub::Exporter::Util;
  26         316393  
  26         144  
7 26         109 use Sub::Exporter 0.950 -setup => {
8             exports => { tolerance => Sub::Exporter::Util::curry_class('new'), },
9             groups => { default => [ qw(tolerance) ] },
10 26     26   4245 };
  26         415  
11              
12 26     26   8803 use Carp ();
  26         45  
  26         304  
13 26     26   96 use Scalar::Util ();
  26         40  
  26         36656  
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   460 keys %_plugins
99             }
100              
101             sub disable_plugin {
102 2     2 1 7 my ($class, $plugin) = @_;
103 2         8 $class->_boot_up;
104 2         5 delete $_plugins{ $plugin };
105 2         6 return;
106             }
107              
108             sub enable_plugin {
109 265     265 1 995 my ($class, $plugin) = @_;
110 265         594 $class->_boot_up;
111              
112             # XXX: there has to be a better test to use here -- rjbs, 2006-01-27
113 265 100       295 unless (eval { $plugin->can('construct') }) {
  265         1299  
114 262 100       10890 eval "require $plugin" or die $@;
115             }
116              
117 264 100       692 unless (eval { $class->validate_plugin($plugin); }) {
  264         978  
118 1         130 Carp::croak "class $plugin is not a valid Number::Tolerant plugin: $@";
119             }
120              
121 263         511 $_plugins{ $plugin } = undef;
122 263         2368 return;
123             }
124              
125             sub validate_plugin {
126 264     264 1 575 my ($class, $plugin) = @_;
127 264         466 for (qw(parse valid_args construct)) {
128 790 100       3146 die "can't $_" unless $plugin->can($_);
129             }
130 263         554 return 1;
131             }
132              
133             my $booted;
134             sub _boot_up {
135 440 100   440   857 return if $booted;
136 26         63 $booted = 1;
137             my @_default_plugins =
138 26         79 map { "Number::Tolerant::Type::$_" }
  260         416  
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         162 __PACKAGE__->enable_plugin($_) for @_default_plugins;
147             }
148              
149             sub new {
150 139     139 1 17103 my $class = shift;
151 139         319 $class->_boot_up;
152 139 100       277 return unless @_;
153 138         183 my $self;
154              
155 138         315 for my $type ($class->_plugins) {
156 855 100       1847 next unless my @args = $type->valid_args(@_);
157 115         316 my $guts = $type->construct(@args);
158              
159 115 100 66     4557 return $guts unless ref $guts and not Scalar::Util::blessed($guts);
160              
161 111 100 100     522 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         12 @_ = ($class, $guts->{min});
167 3         15 goto &new;
168             }
169 108         445 $self = { method => $type, %$guts };
170 108         282 last;
171             }
172              
173 131 100       2499 Carp::confess("couldn't form tolerance from given args") unless $self;
174 108         374 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 5492 my ($class, $string) = @_;
195 34         112 $class->_boot_up;
196 34 100       187 Carp::croak "from_string is a class method" if ref $class;
197 33         138 for my $type (keys %_plugins) {
198 172 100       572 if (defined(my $tolerance = $type->parse($string, $class))) {
199 29         115 return $tolerance;
200             }
201             }
202              
203 4         542 Carp::confess("couldn't form tolerance from given string");
204             }
205              
206             sub stringify {
207 53     53 1 15172 my ($self) = @_;
208              
209 53 100 100     408 return 'any number' unless (defined $self->{min} || defined $self->{max});
210              
211 49         73 my $string = '';
212              
213 49 100       95 if (defined $self->{min}) {
214 37 100       126 $string .= "$self->{min} <" . ($self->{exclude_min} ? q{} : '=') . q{ };
215             }
216              
217 49         65 $string .= 'x';
218              
219 49 100       91 if (defined $self->{max}) {
220 33 100       89 $string .= ' <' . ($self->{exclude_max} ? q{} : '=') . " $self->{max}";
221             }
222              
223 49         403 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 100 3 1 20 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   2776 sub _num_eq { not( _num_gt($_[0],$_[1]) or _num_lt($_[0],$_[1]) ) }
257              
258 86     86   1999 sub _num_ne { not _num_eq(@_) }
259              
260 672 100   672   1723 sub _num_gt { $_[2] ? goto &_num_lt_canonical : goto &_num_gt_canonical }
261              
262 556 100   556   3673 sub _num_lt { $_[2] ? goto &_num_gt_canonical : goto &_num_lt_canonical }
263              
264 50 100   50   95 sub _num_gte { $_[1] == $_[0] ? 1 : goto &_num_gt; }
265              
266 50 100   50   100 sub _num_lte { $_[1] == $_[0] ? 1 : goto &_num_lt; }
267              
268             sub _num_gt_canonical {
269 663 100 100 663   1550 return 1 if $_[0]{exclude_min} and $_[0]{min} == $_[1];
270             defined $_[0]->{min} ? $_[1] < $_[0]->{min} : undef
271 635 100       2293 }
272              
273             sub _num_lt_canonical {
274 565 100 100 565   1139 return 1 if $_[0]{exclude_max} and $_[0]{max} == $_[1];
275             defined $_[0]->{max} ? $_[1] > $_[0]->{max} : undef
276 551 100       2398 }
277              
278 8     8   3844 sub _union { $_[0]->union($_[1]); }
279              
280             sub union {
281 8     8 1 354 require Number::Tolerant::Union;
282 8         31 return Number::Tolerant::Union->new($_[0],$_[1]);
283             }
284              
285 24     24   8874 sub _intersection { $_[0]->intersection($_[1]); }
286              
287             sub intersection {
288 24 100   24 1 60 if (! ref $_[1]) {
289 6 100       9 return $_[1] if $_[0] == $_[1];
290 1         4 Carp::confess "no valid intersection of ($_[0]) and ($_[1])";
291             }
292              
293 18         33 my ($min, $max);
294 18         0 my ($exclude_min, $exclude_max);
295              
296 18 100 100     127 if (defined $_[0]->{min} and defined $_[1]->{min}) {
297 8         25 ($min) = sort {$b<=>$a} ($_[0]->{min}, $_[1]->{min});
  8         25  
298             } else {
299 10 100       54 $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     98 or ($_[1]{min} and $min == $_[1]{min} and $_[1]{exclude_min});
      100        
      100        
      100        
      100        
305              
306 18 100 100     41 if (defined $_[0]->{max} and defined $_[1]->{max}) {
307 8         25 ($max) = sort {$a<=>$b} ($_[0]->{max}, $_[1]->{max});
  8         18  
308             } else {
309 10 100       20 $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     97 or ($_[1]{max} and $max == $_[1]{max} and $_[1]{exclude_max});
      100        
      100        
      100        
      100        
315              
316 18 100 100     39 return $_[0]->new('infinite') unless defined $min || defined $max;
317              
318 17 100       36 return $_[0]->new($min => ($exclude_min ? 'more_than' : 'or_more'))
    100          
319             unless defined $max;
320              
321 13 100       26 return $_[0]->new($max => ($exclude_max ? 'less_than' : 'or_less'))
    100          
322             unless defined $min;
323              
324 10 50 33     28 Carp::confess "no valid intersection of ($_[0]) and ($_[1])"
325             if $max < $min or $min > $max;
326              
327 10         42 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   2034 'bool' => sub { 1 },
411             '0+' => 'numify',
412             '<=>' => sub {
413 90 50   90   221 my $rv = $_[0] == $_[1] ? 0
    100          
    100          
414             : $_[0] < $_[1] ? -1
415             : $_[0] > $_[1] ? 1
416             : die "impossible";
417 90 100       218 $rv *= -1 if $_[2];
418 90         337 return $rv;
419             },
420 26         263 '""' => '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   197 '&' => '_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__