Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

Set::Range - conditional testing on sets

by $code or die (Deacon)
on Apr 23, 2001 at 23:36 UTC ( #74833=sourcecode: print w/ replies, xml ) Need Help??

Category: Miscellaneous
Author/Contact Info perl@simonflack.com
$code or die
http://www.simonflack.com
Description: This module lets you define a range of dates or numeric values and will return which set a given test value is a member of.

Personally, this will save me precious minutes by not having to do a lot of if .. then statements. It's not highly advanced or anything, just quite useful I think. e.g. want to do something depending on the value of x, but don't want the values to be hard-coded or difficult to change\add to?

Please let me know if you have any questions or suggestions - specifically, I'm looking for a nice way of removing that nasty eval statement... Also, do you think it's worth submitting this to CPAN, if so is Set::Range OK?

POD to follow...
package Set::Range;
require Exporter;

use constant DATE_RANGE        => 1;
use constant NUM_RANGE        => 2;
use constant TIME_RANGE        => 3;
use constant EU_DATE_RANGE    => 4;

@ISA = qw(Exporter);
@EXPORT = qw(DATE_RANGE EU_DATE_RANGE NUM_RANGE TIME_RANGE);

sub new {
    my $self = shift;
      my $range = shift;
      return bless $range, $self;
}


sub getSet {
    my ($self, $var, $type) = @_;
    $type = NUM_RANGE unless $type;

    if (($type == DATE_RANGE) || ($type == EU_DATE_RANGE)) {
        $var = _timify($var, $type);
    }

    my $state = 0;
    foreach $state (keys %$self) {
        my ($u, $l) = ($self->{$state}->{upper},
                $self->{$state}->{lower});
        
        if (($type == DATE_RANGE) || ($type == EU_DATE_RANGE)) {
            $upper= _timify($u, $type);
            $lower= _timify($l, $type);
        }
        
        my ($uinc, $linc, $result);
        if ($self->{$state}->{upper_inclusive}) {
            $uinc = '>=';
        } else { $uinc = '>' }
        
        if ($self->{$state}->{lower_inclusive}) {
            $linc = '>=';
        } else { $linc = '>' }
    
        $result = 
        eval "$state if (($u $uinc $var) && ($var $linc $l))";
        
        return $result if $result;

    }
    return 0;
}


sub _timify {
    my ($u, $type) = @_;
    
    require Date::Calc;

    if ($type == EU_DATE_RANGE) {
        $u = Date::Calc::Date_to_Days(Date::Calc::Decode_Date_EU($u));
    } else {
        $u = Date::Calc::Date_to_Days(Date::Calc::Decode_Date_US($u));
    }
    
    
    return $u;    
}

Comment on Set::Range - conditional testing on sets
Download Code
Re: Set::Range - conditional testing on sets
by $code or die (Deacon) on Apr 23, 2001 at 23:44 UTC
    Here's the pod...

    SYNOPSIS

    use Set::Range;
    my %set= ('1' => { lower => 0, upper => 10, upper_inclusive => 1, }, '2' => { lower => 11, upper => 100, lower_inclusive => 1, }, );
    my $range=Set::Range->new(\%set); print $range->getState('19', NUM_RANGE); # prints "2"
    my %set= ('Jan' => { lower => '1/1/2001', upper => '1/31/2001', upper_inclusive => 1, lower_inclusive => 1, }, # Days in January 'Feb' => { lower => '2/1/2001', upper => '2/28/2001', upper_inclusive => 1, lower_inclusive => 1, }, # Days in February );
    my $range=Set::Range->new(\%set);
    print $range->getSet('1/11/2001', DATE_RANGE); # prints "Jan"

    DESCRIPTION

    Set::Range allows you to define ranges of numeric or date values and will return the set that a given test value lies in. This module removes the need for multiple if .. elsif .. (etc) tests and lets you modify the sets on the fly without having to recode the logic in your scripts.

    E.g.: define date ranges and test for which set '1/1/2002' is in.

    METHODS

    new
    This creates the Set::Range Object

    Example: my $range = Set::Range->new(\%sets);

    Pass new() a reference to a Hash containing the set information.

    %sets
    The hash defining the sets contains one hash per set with at least 'upper' and 'lower' defined. 'upper_inclusive' and 'lower_inclusive' are optional and are the equivalent of >= and <= for the upper and lower set boundries.
    The set hash can look like this:
    { 'key1' => { lower => 0, upper => 10 }, 'key2' => { lower => 10, upper => 15, lower_inclusive => 1, }, 'key3' => { lower => 15 upper => 25, lower_inclusive => 1, upper_inclusive => 1, }, }
    etc... The lower and upper values can either be numeric values or date values in the form mm/dd/yyyy or dd/mm/yyyy (see C<getSet> for Euro-formatted dates)
    getSet
    getSet() returns the value of the set that the test item is a member of. Optionally accepts one of the following contants (defaults to numeric): NUM_RANGE, DATE_RANGE, EU_DATE_RANGE, TIME_RANGE(same as NUM_RANGE)

    Examples:

    my $set = $range->getSet(10); my $set = $range->getSet('1/14/2002', DATE_RANGE);

    getSet returns 0 if the test value was not found to be a member of any set.

    Note: Set::Range uses Date::Calc functions to convert the date to a datestamp. I settled on Date::Calc because Time::Local doesn't support years > 2038.

    EXPORT

    NUM_RANGE, DATE_RANGE, EU_DATE_RANGE, TIME_RANGE constants

Re: Set::Range - conditional testing on sets
by japhy (Canon) on Apr 30, 2001 at 04:16 UTC
    Here's my implementation. Documentation will come in a while, and I haven't tested it (I just wrote it, and I'm in the mood for dinner), but here's the code:
    package Set::Range; $VERSION = '1.0j'; # j for japhy ;) sub new { my $class = shift; my $self = bless { CACHE => {}, RANGE => [], }, $class; while (my ($k,$v) = splice(@_, 0, 2)) { my ($low, $high) = split /\s*(?:,|\.{2,})\s*/, $k; unless ($high) { $high = substr($low, 1); chop $low; } my $li = (substr($low, 0, 1, '') eq '['); my $hi = (substr($high, 0, 1, '') eq ']'); my $l = $self->fmt($low); my $h = $self->fmt($high); $self->{CACHE}{$l} = $v if $li; $self->{CACHE}{$h} = $v if $hi; push @{ $self->{RANGE} }, { LO => $l, HI => $h, LO_INC => $li, HI_INC => $hi, VALUE => $v, CODE => ($l == $h && sub { $l == $_[0] }) || ($li && $hi && sub { ($l ne '' && $l <= $_[0]) and ($h ne '' & +& $_[0] <= $h) } ) || ($li && sub { ($l ne '' && $l <= $_[0]) and ($h ne '' && $_[0] + < $h) } ) || ($hi && sub { ($l ne '' && $l < $_[0]) and ($h ne '' && $_[0] +<= $h) } ) || sub { ($l ne '' && $l < $_[0]) and ($h ne '' && $_[0] < $h) } }; } return $self; } sub range { my ($self, $value) = @_; $value = $self->fmt($value); return $self->{CACHE}{$value} if exists $self->{CACHE}{$value}; $_->{CODE}->($value) and return($self->{CACHE}{$value} = $_->{VALUE} +) for @{ $self->{RANGE} }; return; } package Set::Range::Date; @ISA = qw( Set::Range ); sub fmt { my $d = pop; return sprintf "%04d%02d%02d", ($d =~ /(\d{1,2})\D*(\d{1,2})\D*(\d+)/)[2,1,0]; } package Set::Range::Date::Eu; @ISA = qw( Set::Range ); sub fmt { my $d = pop; return sprintf "%04d%02d%02d", ($d =~ /(\d{1,2})\D*(\d{1,2})\D*(\d+)/)[2,0,1]; } package Set::Range::Time; @ISA = qw( Set::Range ); sub fmt { my $t = pop; # assume it's a timestamp return $t unless $t =~ /\D/; # does it look a like 12-hour clock? if ($t =~ /([apAP])/) { my $is_pm = (lc($1) ne 'a'); my @parts = $t =~ /(\d+)/g; $parts[0] %= 12; $parts[0] += 12 if $is_pm; return sprintf '%02d' x 4, @parts; } # otherwise, assume 24-hour clock return sprintf '%02d' x 4, $t =~ /(\d+)/g; } package Set::Range::Number; @ISA = qw( Set::Range ); sub fmt { pop } 1; __END__
    Sample use is:
    use Set::Range; my $r = Set::Range::Date->new( '[1/1/2001,12/31/2001]' => "", '[,1/1/2001)' => "before ", '(12/31/2001,]' => "after ", ); print "Today is ", $r->range('5/6/2000'), "now";
    Mine uses standard set notation (a bracket means inclusive, and a parenthesis means exclusive) as the key, and some value (such as a code reference) for the value. The sets should be sent in a meaningful order -- the order they'll be tested in.

    I also use OO design to specify the formatting as a sub-class action, and leave the actual comparing up to the main class.

    This isn't meant to be a challenge or whatever to your module, it's just how I would write the thing. Yours looks rather nice (save that eval(), which you tell me you've gotten rid of in your CPAN'd version).

    japhy -- Perl and Regex Hacker
      This isn't meant to be a challenge or whatever to your module, it's just how I would write the thing. Yours looks rather nice (save that eval(), which you tell me you've gotten rid of in your CPAN'd version).

      Absolutely no offense taken - I'm not into the whole ego thing, I think this is the whole point of open source: It's really nice to see how this can be developed into a useful module that people can use. Coming from a mainly Windows background this is a new experience for me - I like it. Anyway, I did ask for comments\revisions etc.

      Simon
      $code or die
      $ perldoc perldoc

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://74833]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others browsing the Monastery: (8)
As of 2014-09-23 10:12 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    How do you remember the number of days in each month?











    Results (216 votes), past polls