File Coverage

blib/lib/Devel/INC/Sorted.pm

Criterion	Covered	Total	%
statement	76	84	90.4
branch	6	6	100.0
condition	6	8	75.0
subroutine	23	28	82.1
pod	0	5	0.0
total	111	131	84.7

#!/usr/bin/perl

package Devel::INC::Sorted;
use base qw(Exporter Tie::Array);

use strict;
use warnings;

use sort 'stable';

use Scalar::Util qw(blessed reftype);
use Tie::RefHash;

our $VERSION = "0.02";

our @EXPORT_OK = qw(inc_add_floating inc_float_entry inc_unfloat_entry untie_inc);

tie our %floating, 'Tie::RefHash';

sub import {
	my ( $self, @args ) = @_;
	$self->tie_inc( grep { ref } @args ); # if a code ref is given, pass it to TIEARRAY
	$self->export_to_level(1, $self, @args);
}

sub _args {
	my ( $self, @args );

	if (
		( blessed($_[0]) or defined($_[0]) && !ref($_[0]) ) # class or object
			and
		( $_[0]->isa(__PACKAGE__) )
	) {
		$self = shift;
	} else {
		$self = __PACKAGE__;
	}

	return ( $self->tie_inc, @_ );
}

sub inc_add_floating {
	my ( $self, @args ) = &_args;

	$self->inc_float_entry(@args);

	$self->PUSH(@args);
}

sub inc_float_entry {
	my ( $self, @args ) = &_args;

	@floating{@args} = ( (1) x @args );

	$self->_fixup;
}

sub inc_unfloat_entry {
	my ( $self, @args ) = &_args;

	delete @floating{@args};

	$self->_fixup;
}

sub tie_inc {
	my ( $self, @args ) = @_;
	return $self if ref $self;
	return tied @INC if tied @INC;
	tie @INC, $self, $args[0], @INC;
}

sub untie_inc {
	my ( $self ) = &_args;
	no warnings 'untie'; # untying while tied() is referenced elsewhere warns
	untie @INC;
	@INC = @{ $self->{array} };
}

# This code was adapted from Tie::Array::Sorted::Lazy
# the reason it's not a subclass is because neither ::Sorted nor ::Sorted::Lazy
# provide a stably sorted array, which is bad for our default comparator

sub TIEARRAY {
	my ( $class, $comparator, @orig ) = @_;

	$comparator ||= sub {
		my ( $left, $right ) = @_;
		exists $floating{$right} <=> exists $floating{$left};
	};

	bless {
		array => \@orig,
		comp  => $comparator,
	}, $class;
}

sub STORE {
	my ($self, $index, $elem) = @_;
	$self->{array}[$index] = $elem;
	$self->_fixup();
	$self->{array}[$index];
}

sub PUSH {
	my $self = shift;
	my $ret = push @{ $self->{array} }, @_;
	$self->_fixup();
	$ret;
}

sub UNSHIFT {
	my $self = shift;
	my $ret = unshift @{ $self->{array} }, @_;
	$self->_fixup();
	$ret;
}

sub _fixup {
	my $self = shift;
	$self->{array} = [ sort { $self->{comp}->($a, $b) } @{ $self->{array} } ];
	$self->{dirty} = 0;
}

sub FETCH {
	$_[0]->{array}->[ $_[1] ];
}

sub FETCHSIZE {
	scalar @{ $_[0]->{array} }
}

sub STORESIZE {
	$#{ $_[0]->{array} } = $_[1] - 1;
}

sub POP {
	pop(@{ $_[0]->{array} });
}

sub SHIFT {
	shift(@{ $_[0]->{array} });
}

sub EXISTS {
	exists $_[0]->{array}->[ $_[1] ];
}

sub DELETE {
	delete $_[0]->{array}->[ $_[1] ];
}

sub CLEAR {
	@{ $_[0]->{array} } = ()
}

__PACKAGE__

__END__