Commit | Line | Data |
3fea05b9 |
1 | # $Id: Compare.pm 846 2002-10-25 15:46:01Z richardc $ |
2 | package Number::Compare; |
3 | use strict; |
4 | use Carp qw(croak); |
5 | use vars qw/$VERSION/; |
6 | $VERSION = '0.01'; |
7 | |
8 | sub new { |
9 | my $referent = shift; |
10 | my $class = ref $referent || $referent; |
11 | my $expr = $class->parse_to_perl( shift ); |
12 | |
13 | bless eval "sub { \$_[0] $expr }", $class; |
14 | } |
15 | |
16 | sub parse_to_perl { |
17 | shift; |
18 | my $test = shift; |
19 | |
20 | $test =~ m{^ |
21 | ([<>]=?)? # comparison |
22 | (.*?) # value |
23 | ([kmg]i?)? # magnitude |
24 | $}ix |
25 | or croak "don't understand '$test' as a test"; |
26 | |
27 | my $comparison = $1 || '=='; |
28 | my $target = $2; |
29 | my $magnitude = $3; |
30 | $target *= 1000 if lc $magnitude eq 'k'; |
31 | $target *= 1024 if lc $magnitude eq 'ki'; |
32 | $target *= 1000000 if lc $magnitude eq 'm'; |
33 | $target *= 1024*1024 if lc $magnitude eq 'mi'; |
34 | $target *= 1000000000 if lc $magnitude eq 'g'; |
35 | $target *= 1024*1024*1024 if lc $magnitude eq 'gi'; |
36 | |
37 | return "$comparison $target"; |
38 | } |
39 | |
40 | sub test { $_[0]->( $_[1] ) } |
41 | |
42 | 1; |
43 | |
44 | __END__ |
45 | |
46 | =head1 NAME |
47 | |
48 | Number::Compare - numeric comparisons |
49 | |
50 | =head1 SYNOPSIS |
51 | |
52 | Number::Compare->new(">1Ki")->test(1025); # is 1025 > 1024 |
53 | |
54 | my $c = Number::Compare->new(">1M"); |
55 | $c->(1_200_000); # slightly terser invocation |
56 | |
57 | =head1 DESCRIPTION |
58 | |
59 | Number::Compare compiles a simple comparison to an anonymous |
60 | subroutine, which you can call with a value to be tested again. |
61 | |
62 | Now this would be very pointless, if Number::Compare didn't understand |
63 | magnitudes. |
64 | |
65 | The target value may use magnitudes of kilobytes (C<k>, C<ki>), |
66 | megabytes (C<m>, C<mi>), or gigabytes (C<g>, C<gi>). Those suffixed |
67 | with an C<i> use the appropriate 2**n version in accordance with the |
68 | IEC standard: http://physics.nist.gov/cuu/Units/binary.html |
69 | |
70 | =head1 METHODS |
71 | |
72 | =head2 ->new( $test ) |
73 | |
74 | Returns a new object that compares the specified test. |
75 | |
76 | =head2 ->test( $value ) |
77 | |
78 | A longhanded version of $compare->( $value ). Predates blessed |
79 | subroutine reference implementation. |
80 | |
81 | =head2 ->parse_to_perl( $test ) |
82 | |
83 | Returns a perl code fragment equivalent to the test. |
84 | |
85 | =head1 AUTHOR |
86 | |
87 | Richard Clamp <richardc@unixbeard.net> |
88 | |
89 | =head1 COPYRIGHT |
90 | |
91 | Copyright (C) 2002 Richard Clamp. All Rights Reserved. |
92 | |
93 | This module is free software; you can redistribute it and/or modify it |
94 | under the same terms as Perl itself. |
95 | |
96 | =head1 SEE ALSO |
97 | |
98 | http://physics.nist.gov/cuu/Units/binary.html |
99 | |
100 | =cut |