package Algorithm::SkipList::StringRangeNode;
require 5.006;
use strict;
use warnings; ## ::register __PACKAGE__;
use Carp;
# no Carp::Assert;
use base 'Algorithm::SkipList::Node';
sub key_cmp {
my $self = shift;
# assert( UNIVERSAL::isa($self, __PACKAGE__) ), if DEBUG;
my $left = $self->key;
my $right = shift;
unless (defined $left) { return -1; }
if ($right =~ /,/) {
my ($lo, $hi) = map { $_ || "" } split /,/, $left;
$hi = "", unless (defined $hi);
my ($lr, $hr) = map { $_ || "" } split /,/, $right;
$hr = "", unless (defined $hr);
my $lo_cmp = ($hr eq "") ?
(($lo ne "") ? -1 : -1 ) : # ?
(($lo ne "") ? ($lo cmp $hr) : -1);
my $lr_cmp = ($lr eq "") ?
(($lo ne "") ? 1 : 0 ) :
(($lo ne "") ? ($lo cmp $lr) : -1);
my $hi_cmp = ($lr eq "") ?
(($hi ne "") ? 1 : 1 ) :
(($hi ne "") ? ($hi cmp $lr) : 1);
my $hr_cmp = ($hr eq "") ?
(($hi ne "") ? -1 : 0 ) :
(($hi ne "") ? ($hi cmp $hr) : 1);
if ( (($lo_cmp==-1) && ($hi_cmp==1) && (!$lr_cmp) && (!$hr_cmp)) ||
((!$lo_cmp) && (!$hi_cmp) && (!$lr_cmp) && (!$hr_cmp)) ){
return 0;
} elsif (($lo_cmp==1) && ($hi_cmp==1) &&
($lr_cmp==1) && ($hr_cmp==1)) {
return 1;
} elsif (($lo_cmp==-1) && ($hi_cmp==-1) &&
($lr_cmp==-1) && ($hr_cmp==-1)) {
return -1;
} else {
confess "Overlapping ranges";
}
} else {
my ($lo, $hi) = split /,/, $left;
my $lo_cmp = ($lo ne "") ? ($lo cmp $right) : -1;
my $hi_cmp = ($hi ne "") ? ($hi cmp $right) : 1;
# assert( $hi_cmp >= $lo_cmp ), if DEBUG;
if (($lo_cmp <= 0) && ($hi_cmp >= 0)) {
return 0;
} elsif ($hi_cmp < 0) {
return -1;
} elsif ($lo_cmp > 0) {
return 1;
}
}
}
1;
package Algorithm::SkipList::NumericRangeNode;
require 5.006;
use strict;
use warnings; # ::register __PACKAGE__;
use Carp;
# no Carp::Assert;
use base 'Algorithm::SkipList::Node';
sub key_cmp {
my $self = shift;
# assert( UNIVERSAL::isa($self, __PACKAGE__) ), if DEBUG;
my $left = $self->key;
my $right = shift;
unless (defined $left) { return -1; }
if ($right =~ /,/) {
my ($lo, $hi) = map { $_ || "" } split /,/, $left;
$hi = "", unless (defined $hi);
my ($lr, $hr) = map { $_ || "" } split /,/, $right;
$hr = "", unless (defined $hr);
my $lo_cmp = ($hr eq "") ?
(($lo ne "") ? -1 : -1 ) : # ?
(($lo ne "") ? ($lo <=> $hr) : -1);
my $lr_cmp = ($lr eq "") ?
(($lo ne "") ? 1 : 0 ) :
(($lo ne "") ? ($lo <=> $lr) : -1);
my $hi_cmp = ($lr eq "") ?
(($hi ne "") ? 1 : 1 ) :
(($hi ne "") ? ($hi <=> $lr) : 1);
my $hr_cmp = ($hr eq "") ?
(($hi ne "") ? -1 : 0 ) :
(($hi ne "") ? ($hi <=> $hr) : 1);
# print join(" ", $hi, $hr, $lo_cmp, $lr_cmp, $hi_cmp, $hr_cmp), "\n";
if ( (($lo_cmp==-1) && ($hi_cmp==1) && (!$lr_cmp) && (!$hr_cmp)) ||
((!$lo_cmp) && (!$hi_cmp) && (!$lr_cmp) && (!$hr_cmp)) ){
return 0;
} elsif (($lo_cmp==1) && ($hi_cmp==1) &&
($lr_cmp==1) && ($hr_cmp==1)) {
return 1;
} elsif (($lo_cmp==-1) && ($hi_cmp==-1) &&
($lr_cmp==-1) && ($hr_cmp==-1)) {
return -1;
} else {
confess "Overlapping ranges";
}
} else {
my ($lo, $hi) = split /,/, $left;
$lo = "", unless (defined $lo);
$hi = "", unless (defined $hi);
$right = "", unless (defined $right);
my $lo_cmp = ($lo ne "") ? ($lo <=> $right) : -1;
my $hi_cmp = ($hi ne "") ? ($hi <=> $right) : 1;
# assert( $hi_cmp >= $lo_cmp ), if DEBUG;
if (($lo_cmp <= 0) && ($hi_cmp >= 0)) {
return 0;
} elsif ($hi_cmp < 0) {
return -1;
} elsif ($lo_cmp > 0) {
return 1;
}
}
}
1;
package Tie::RangeHash::TYPE_STRING;
use base 'Algorithm::SkipList::StringRangeNode';
1;
package Tie::RangeHash::TYPE_NUMBER;
use base 'Algorithm::SkipList::NumericRangeNode';
1;
package Tie::RangeHash;
require 5.006;
use strict;
use warnings; # ::register __PACKAGE__;
use Carp;
# no Carp::Assert;
use Algorithm::SkipList 1.02;
our $VERSION = '1.05';
# $VERSION = eval $VERSION;
use constant TYPE_STRING => 'Algorithm::SkipList::StringRangeNode';
use constant TYPE_NUMBER => 'Algorithm::SkipList::NumericRangeNode';
# we use the full Exporter rather than something like Exporter::Lite
# because Algorithm::SkipList uses the full exporter.
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = ();
our @EXPORT_OK = qw( TYPE_STRING TYPE_NUMBER );
sub new {
my $class = shift;
my $self = {
SKIPLIST => undef,
NODECLASS => TYPE_STRING,
};
bless $self, $class;
{
my %ARGLIST = ( map { $_ => 1 } qw( Type ) );
my %args;
if (ref($_[0]) eq "HASH") {
%args = %{$_[0]};
} else {
%args = @_;
}
foreach my $arg_name (keys %args) {
if ($ARGLIST{$arg_name}) {
my $method = "_set_" . $arg_name;
$self->$method( $args{ $arg_name } );
} else {
croak "Invalid parameter name: ``$arg_name\'\'";
}
}
}
$self->{SKIPLIST} = new Algorithm::SkipList(
node_class => $self->{NODECLASS},
);
return $self;
}
sub _set_Type {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my $node_class = shift;
my $node = new $node_class;
# assert( UNIVERSAL::isa($node, "Algorithm::SkipList::Node" ) ), if DEBUG;
$self->{NODECLASS} = $node_class;
}
sub fetch {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my $key = shift;
return $self->{SKIPLIST}->find( $key );
}
sub fetch_key {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my $key = shift;
my ($x, $update_ref) = $self->{SKIPLIST}->_search($key);
if ($x->key_cmp($key) == 0) {
return (wantarray) ? ($x->key => $x->value) : $x->key;
} else {
return;
}
}
sub fetch_overlap {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my $key = shift;
my ($low, $high) = split /,/, $key;
my @nodes = $self->{SKIPLIST}->_search_nodes($low, undef, $high);
unless (@nodes) {
@nodes = $self->{SKIPLIST}->_search_nodes(undef, undef, $high);
}
if (@nodes) {
return map { $_->value } @nodes;
}
else {
return;
}
}
sub key_exists {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my $key = shift;
$self->{SKIPLIST}->exists($key);
}
sub add {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my ($key, $value) = @_;
$self->{SKIPLIST}->insert($key, $value);
}
sub clear {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
$self->{SKIPLIST}->clear;
}
sub remove {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my $key = shift;
# We could simply call $self->{SKIPLIST}->delete( $key ), but we
# want to make sure that the user has specified the exact key that
# is used (to keep compatability with previous versions)
my ($x, $update_ref) = $self->{SKIPLIST}->_search($key);
if ($x->key eq $key) {
return $self->{SKIPLIST}->delete( $key );
} else {
return;
}
}
sub first_key {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
return $self->{SKIPLIST}->first_key;
}
sub next_key {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
my $last_key = shift;
return $self->{SKIPLIST}->next_key( $last_key );
}
sub reset {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
$self->{SKIPLIST}->reset;
}
sub size {
my $self = shift;
# assert( UNIVERSAL::isa($self, "Tie::RangeHash") ), if DEBUG;
return $self->{SKIPLIST}->size;
}
BEGIN
{
# make aliases to methods...
no strict;
*TIEHASH = \&new;
*STORE = \&add;
*FETCH = \&fetch;
*EXISTS = \&key_exists;
*CLEAR = \*clear;
*DELETE = \*remove;
*FIRSTKEY = \*first_key;
*NEXTKEY = \*next_key;
}
1;
__END__
=head1 NAME
Tie::RangeHash - Allows hashes to associate values with a range of keys
=head1 REQUIREMENTS
L<Algorithm::SkipList> is required. Otherwise it uses
standard modules.
=head1 SYNOPSIS
use Tie::RangeHash;
tie %hash, 'Tie::RangeHash';
$hash{'A,C'} = 1;
$hash{'D,F'} = 2;
$hash{'G,K'} = 3;
$hash{'E'}; # returns '2'
$hash{'BB'}; # returns '1'
$hash{'KL'}; # returns nothing ('undef')
There is also an object-oriented interface:
$hash = new Tie::RangeHash;
$hash->add('A,C', 1);
$hash->add('G,I', 2);
$hash->fetch('H'); # returns '2'
=head1 DESCRIPTION
This module allows hashes to associate a value with a I<range> of keys rather
than a single key.
For example, you could pass date ranges to the hash and then query it with
a specific date, like so:
$cost{'1999-12-15,2000-01-14'} = 150;
$cost{'2000-01-15,2000-02-14'} = 103;
$cost{'2000-02-15,2000-03-14'} = 97;
and then query the cost on a specific date:
$this_cost = $cost{'2000-02-08'};
Numeric key ranges can also be used:
tie %hash, 'Tie::RangeHash', {
Type => Tie::RangeHash::TYPE_NUMBER
};
$hash{'1.4,1.8'} = 'Jim';
$hash{'1.0,1.399999'} = 'Ned';
$hash{'1.800001,2.0'} = 'Boo';
Custom comparison routines to support alternate datatypes can be
implemented by specifying a new node type for L<Algorithm::SkipList>.
=head2 Object-Oriented Interface
L<Tie::RangeHash> has an object-oriented interface as an alternative to
using a tied hash.
=over
=item new
Creates a new object.
$obj = Tie::RangeHash->new( %attr );
C<%attr> is a hash containing the attributes described above.
=item add
Adds a new key/value pair to the object.
$obj->add( $key, $value );
C<$key> may be a string value in the form of C<low,high> (for example,
"Samantha,Selma").
=item fetch
$value = $obj->fetch( $key );
Returns the value associated with C<$key>. (C<$key> may be in the form of
C<low,high> or any key between C<low> and C<high>.)
If they key range overlaps multiple keys, it will return a fatal
error. In such cases, use L</fetch_overlap>.
=item fetch_overlap
@values = $obj->fetch_overlap("$low,$high");
Retrieves multiple values associated with a range of keys between C<$low>
and C<$high>. Capable of fetching values from overlapping keys.
See L</KNOWN ISSUES> for more information about overlapping keys.
=item fetch_key
$real_key = $obj->fetch_key( $key );
($real_key, $value) = $obj->fetch( $key );
Like L</fetch>, but it returns the I<key range> that was matched rather
than the value. If it is called in an array context, it will return the
key and value.
=item key_exists
if ($obj->key_exists( $key )) { .. }
Returns c<true> if C<$key> has been defined (even if the value is C<undef>).
(C<$key> is in the same form as is used by the L</fetch> method.)
=item clear
$obj->clear();
Deletes all keys and values defined in the object.
=item remove
$value = $obj->remove( $key );
Deletes the C<$key> from the object and returnes the associated value.
(C<$key> is in the same form as is used by the C<fetch> method.) If
C<$key> is not the exact C<low,high> range, a warning will be emitted.
=item first_key
$key = $obj->first_key();
Returns the first.
=item next_key
$key = $obj->next_key($last_key);
Returns the next key in the iteration.
=back
=head2 Implementation Notes
Internally, the hash uses skip lists. Skip lists are an alternative
to binary trees. For more information, see L<Algorithm::SkipList>.
Future versions may be changed to use something else that is more
efficient.
=head1 KNOWN ISSUES
The is a new version of the module and has behaves differently
compared to older versions. This is due to using the
L<Algorithm::SkipList> module for maintaining the underlying data rather
than re-implementing it. While this improves the maintainability with
the code, it increases incompatability with previous versions.
Some of the changes include:
=over
=item Overlapping keys cause fatal errors instead of warnings
Because the key comparison is now performed in the skip list node,
there is no obvious way for it to give a warning and return a
meaningful result. So instead the code dies. If you code relies on
the possibility of using overlapping keys, then it may be more
appropriate to have it test the code:
eval {
$hash{'111,999'} = $value;
};
This error can also occur by merely testing a hash, so it is important
to run some checks if you are testing hash ranges:
eval {
if ($hash{'111,999'} == $value) { ... }
}
Another option is to use L</fetch_overlap> instead.
=item Keys can be redefined
Nodes can now be redefined. For example:
$hash{'1,3'} = $value;
...
$hash{'1,3'} = $new_value;
...
$hash{'2'} = $new_value;
Note that a range is no longer required.
=item Non-range keys can be added.
When inserting a key, C<$hash{'x'}> will be treated like C<$hash{'x,x'}>.
=item Open-ended ranges are allowed.
Open ended ranges are now supported. So the following can be added:
$hash{',10'} = $upper_bound;
$hash{'11,'} = $lower_bound;
Note that once open-ended ranges are defined, they are permenently
open-ended unless the final range is deleted. Thus,
$hash{'12,13'}
refers to the key C<"11,">.
=item Array references can no longer be keys.
The following is I<not> supported anymore:
$hash{ \@array ) = $value;
=item warnings no longer registered.
Warning registration is no longer used. This may change in the future.
=item Custom separators and comparisons are not supported.
Only commas can be used as separators.
To customize separators and comparisons, you will have to specify a
custom C<Algorithm::SkipList::Node> method.
=back
See the L<Changes> file for a more complete list of changes and
incompatabilities.
If your code does not rely on these quirks, then you should be able to
substitute with no problems.
=head1 SEE ALSO
A module with similar functionality for numerical values is L<Array::IntSpan>.
L<Algorithm::SkipList> for more information on skip lists.
=head1 AUTHOR
Robert Rothenberg <rrwo at cpan.org>
=head2 Acknowledgements
Charles Huff <charleshuff atdecisionresearch.com> for suggestions and
bug reports.
Sam Tregar <sam at tregar.com> for optimization suggestions.
Various Perl Monks L<http://www.perlmonks.org> for advice and code snippets.
=head2 Suggestions and Bug Reporting
Feedback is always welcome. Please use the CPAN Request Tracker at
L<http://rt.cpan.org> to submit bug reports.
=head1 LICENSE
Copyright (C) 2000-2008 Robert Rothenberg. All rights reserved.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut