File Coverage

blib/lib/Tree/RB/XS.pm

Criterion	Covered	Total	%
statement	52	54	96.3
branch	21	24	87.5
condition	19	34	55.8
subroutine	18	19	94.7
pod	5	5	100.0
total	115	136	84.5

package Tree::RB::XS;
$Tree::RB::XS::VERSION = '0.20';
# VERSION
# ABSTRACT: Red/Black Tree and LRU Cache implemented in C

use strict;
use warnings;
use Carp;
use Scalar::Util ();
require XSLoader;
XSLoader::load('Tree::RB::XS', $Tree::RB::XS::VERSION);
use Exporter 'import';
our @_key_types= qw( KEY_TYPE_ANY KEY_TYPE_INT KEY_TYPE_FLOAT KEY_TYPE_BSTR KEY_TYPE_USTR );
our @_cmp_enum= qw( CMP_PERL CMP_INT CMP_FLOAT CMP_MEMCMP CMP_STR CMP_UTF8 CMP_FOLDCASE CMP_NUMSPLIT CMP_NUMSPLIT_FOLDCASE );
*CMP_UTF8= *CMP_STR; # back-compat
our @_lookup_modes= qw( GET_EQ GET_EQ_LAST GET_GT GET_LT GET_GE GET_LE GET_LE_LAST GET_NEXT GET_PREV
                        GET_OR_ADD LUEQUAL LUGTEQ LULTEQ LUGREAT LULESS LUNEXT LUPREV );
our @EXPORT_OK= (@_key_types, @_cmp_enum, @_lookup_modes, 'cmp_numsplit');
our %EXPORT_TAGS= (
	key_type => \@_key_types,
	cmp      => \@_cmp_enum,
	lookup   => \@_lookup_modes,
	get      => \@_lookup_modes,
	all      => \@EXPORT_OK,
);

if ($] < 5.016) {
   # Before 5.16, perl didn't have 'fc' and CORE::lc wasn't a real sub, so need to wrap the op in our own sub.
   # If anyone cares about the difference between 'fc' and 'lc' they can monkey-patch this.
   eval('sub _fc_impl { lc shift } 1')
      or die $@;
}



*root= *root_node;
*min= *min_node;
*max= *max_node;
*nth= *nth_node;
*oldest= *oldest_node;
*newest= *newest_node;


sub iter {
	my ($self, $key_or_node, $mode)= @_;
	$key_or_node= $self->get_node($key_or_node, @_ > 2? $mode : GET_GE())
		if @_ > 1 && ref $key_or_node ne 'Tree::RB::XS::Node';
	Tree::RB::XS::Iter->_new($key_or_node || $self, 1);
}

sub rev_iter {
	my ($self, $key_or_node, $mode)= @_;
	$key_or_node= $self->get_node($key_or_node, @_ > 2? $mode : GET_LE_LAST())
		if @_ > 1 && ref $key_or_node ne 'Tree::RB::XS::Node';
	Tree::RB::XS::Iter->_new($key_or_node || $self, -1);
}

sub iter_newer {
	my ($self, $node)= @_;
	Tree::RB::XS::Iter->_new($node || $self, 2);
}

sub iter_older {
	my ($self, $node)= @_;
	Tree::RB::XS::Iter->_new($node || $self, -2);
}

*Tree::RB::XS::Node::min=         *Tree::RB::XS::Node::left_leaf;
*Tree::RB::XS::Node::max=         *Tree::RB::XS::Node::right_leaf;
*Tree::RB::XS::Node::successor=   *Tree::RB::XS::Node::next;
*Tree::RB::XS::Node::predecessor= *Tree::RB::XS::Node::prev;

sub Tree::RB::XS::Node::strip {
	my ($self, $cb)= @_;
	my ($at, $next, $last)= (undef, $self->left_leaf || $self, $self->right_leaf || $self);
	do {
		$at= $next;
		$next= $next->next;
		if ($at != $self) {
			$at->prune;
			$cb->($at) if $cb;
		}
	} while ($at != $last);
}

sub Tree::RB::XS::Node::as_lol {
	my $self= $_[1] || $_[0];
	[
		$self->left? $self->left->as_lol : '*',
		$self->right? $self->right->as_lol : '*',
		($self->color? 'R':'B').':'.($self->key||'')
	]
}

sub Tree::RB::XS::Node::iter {
	Tree::RB::XS::Iter->_new($_[0], 1);
}

sub Tree::RB::XS::Node::rev_iter {
	Tree::RB::XS::Iter->_new($_[0], -1);
}

sub Tree::RB::XS::Node::iter_newer {
	Tree::RB::XS::Iter->_new($_[0], 2);
}

sub Tree::RB::XS::Node::iter_older {
	Tree::RB::XS::Iter->_new($_[0], -2);
}


# I can't figure out how to do the closure in XS yet
sub Tree::RB::XS::Iter::_new {
	my $class= shift;
	my ($self,$y);
	$self= bless sub { Tree::RB::XS::Iter::next($y) }, $class;
	Scalar::Util::weaken($y= $self);
	$self->_init(@_);
}
sub Tree::RB::XS::Iter::clone {
	my $self= shift;
	ref($self)->_new($self);
}


sub hseek {
	my ($self, $key, $opts)= @_;
	if (@_ == 2 && ref $key eq 'HASH') {
		$opts= $key;
		$key= $opts->{'-key'};
	}
	my $reverse= $opts && $opts->{'-reverse'} || 0;
	my $node= defined $key? $self->get_node($key, $reverse? GET_LE_LAST() : GET_GE()) : undef;
	$self->_set_hashiter($node, $reverse);
}


*LUEQUAL= *GET_EQ;
*LUGTEQ=  *GET_GE;
*LUGTLT=  *GET_LE;
*LUGREAT= *GET_GT;
*LULESS=  *GET_LT;
*LUPREV=  *GET_PREV;
*LUNEXT=  *GET_NEXT;


1;

__END__