File Coverage

blib/lib/PerlX/Window.pm

Criterion	Covered	Total	%
statement	88	103	85.4
branch	13	22	59.0
condition	2	6	33.3
subroutine	22	32	68.7
pod	2	2	100.0
total	127	165	76.9

use 5.016000;
use strict;
use warnings;

package PerlX::Window;

our $AUTHORITY = 'cpan:TOBYINK';
our $VERSION   = '0.004';

use Data::Alias;
use Exporter::Shiny (our @EXPORT = qw( window window_pos ));
use Scalar::Util qw( weaken );

BEGIN {
	my $impl;
	$impl ||= eval { require Hash::FieldHash;       'Hash::FieldHash' };
	$impl ||= do   { require Hash::Util::FieldHash; 'Hash::Util::FieldHash' };
	$impl->import('fieldhash');
};

our ($window, @window);

sub _exporter_validate_opts
{
	my $me = shift;
	my ($opts) = @_;

	return if ref $opts->{into};

	no strict qw(refs);
	*{$opts->{into} . "::window"} = \(my $tmp);
	*{$opts->{into} . "::window"} = [];
	$me->_setup_magic_string(\${$opts->{into} . "::window"});
	$me->_setup_magic_array(\@{$opts->{into} . "::window"});
}

my $scalar_wiz;
sub _setup_magic_string
{
	shift;
	my ($ref) = @_;

	if (eval { require Variable::Magic })
	{
		$scalar_wiz = Variable::Magic::wizard(
			get => sub { ${$_[0]} = $window; 1 },
			set => sub { $window = ${$_[0]}; 1 },
		);
		Variable::Magic::cast($ref, $scalar_wiz);
	}
	else
	{
		unless (exists(&PerlX::Window::_TieScalar::TIESCALAR))
		{
			eval q ~
				package #
					PerlX::Window::_TieScalar;
				sub TIESCALAR { my $tmp = undef; bless \$tmp, $_[0] }
				sub FETCH     { $PerlX::Window::window }
				sub STORE     { $PerlX::Window::window = $_[1] }
				1;
			~ or die("Something went horribly wrong: $@");
		}
		tie($$ref, 'PerlX::Window::_TieScalar');
	}
}

sub _setup_magic_array
{
	shift;
	my ($ref) = @_;

	unless (exists(&PerlX::Window::_TieArray::TIEARRAY))
	{
		eval q ~
			package #
				PerlX::Window::_TieArray;
			use Carp;
			sub TIEARRAY  { my $tmp = undef; bless \$tmp, $_[0] }
			sub STORE     { $PerlX::Window::window[ $_[1] ] = $_[2] }
			sub FETCH     { $PerlX::Window::window[ $_[1] ] }
			sub FETCHSIZE { scalar @PerlX::Window::window }
			sub STORESIZE { croak("Array has a fixed size") }
			sub EXTEND    { () }
			sub EXISTS    { !!1 }
			sub DELETE    { croak("Array element cannot be deleted") }
			sub CLEAR     { croak("Array has a fixed size") }
			sub PUSH      { croak("Array has a fixed size") }
			sub POP       { croak("Array has a fixed size") }
			sub SHIFT     { croak("Array has a fixed size") }
			sub UNSHIFT   { croak("Array has a fixed size") }
			sub SPLICE    { croak("Array has a fixed size") }
			1;
		~ or die("Something went horribly wrong: $@");
	}
	tie(@$ref, 'PerlX::Window::_TieArray');
}

fieldhash(my %pos);
my $last;

sub window (\[$@]$) :lvalue
{
	my ($ref, $n) = @_;

	$pos{$ref} = -1
		unless defined $pos{$ref};

	weaken( $last = $ref );
	++$pos{$ref};

	ref($ref) eq 'ARRAY'
		? _window_on_array(@_)
		: _window_on_string(@_);
}

sub window_pos (;\[$@]) :lvalue
{
	my ($ref) = @_ ? @_ : ($last);
	$pos{$ref};
}

sub _window_on_array :lvalue
{
	my ($ref, $n) = @_;
	my $pos = $pos{$ref};

	if ($pos + $n > scalar(@$ref))
	{
		alias( @window = () );
		$pos{$ref} = undef;
		return;
	}

	alias( @window = @{$ref}[$pos .. $pos+$n-1] );
	@window;
}

sub _window_on_string :lvalue
{
	my ($ref, $n) = @_;
	my $pos = $pos{$ref};

	if ($pos + $n > length($$ref))
	{
		my $tmp = undef;
		alias( $window = $tmp );
		$pos{$ref} = undef;
		return;
	}

	alias( $window = substr($$ref, $pos, $n) );
	$window;
}

1;

__END__