File Coverage

blib/lib/Unicode/Overload.pm

Criterion	Covered	Total	%
statement	79	93	84.9
branch	26	40	65.0
condition	4	6	66.6
subroutine	18	18	100.0
pod			n/a
total	127	157	80.8

package Unicode::Overload;

use utf8;
use strict;
use warnings; # XXX Version-dependent
use Filter::Simple;
use Carp;

#use charnames ':full'; # AHA XXX THIS IS THE MODULE THAT CAUSES $WEIRD_ERROR
use vars qw($VERSION);

$VERSION = '0.01';

sub _map_params
	{
	my %legal_types =
		(
		prefix => 1,
		postfix => 1,
		infix => 1,
		outfix => 1,
		);
	my %ops = ();
	for(my $i=0;$i<@_;$i+=3)
		{
		my ($name,$type,$sub) = @_[$i..$i+2];
		croak "Illegal type '$type' for '$name'\n"
			unless defined $legal_types{$type};
		croak "Not a subroutine reference for '$name'\n"
			unless ref $sub eq 'CODE';
		croak "Outfix type requires an array reference of names\n"
			if $type eq 'outfix' and ref($name) ne 'ARRAY';
		croak "Outfix type only takes two characters\n"
			if $type eq 'outfix' and @$name != 2;

		if(ref $name eq 'ARRAY')
			{
			$ops{$name->[0]} = [ 'outfix_l' => $sub ];
			$ops{$name->[1]} = [ 'outfix_r' => $sub ];
			}
		else
			{
			$ops{$name} = [ $type => $sub ];
			}
		}
	\%ops;
	}

sub _unicode_subchr
	{
	my ($str_ref,$pos,$rep) = @_;
	my $len = 1;
	$len++ if ord(substr($$str_ref,$pos,1)) > 0x7F;
	$len++ if ord(substr($$str_ref,$pos,1)) > 0xDF;
	$len++ if ord(substr($$str_ref,$pos,1)) > 0xEF;
	substr($$str_ref,$pos,$len) = $rep;
	}

sub _outfix_r
	{
	my ($ops,$str_ref) = @_;
	for my $char (keys %$ops)
		{
		next unless $ops->{$char}[0] eq 'outfix_r';
		my $pos;
		while(($pos = index($$str_ref,$char)) >= 0)
			{
			_unicode_subchr($str_ref,$pos,')');
			}
		}
	}

sub _outfix_l
	{
	my ($ops,$str_ref) = @_;
	for my $char (keys %$ops)
		{
		next unless $ops->{$char}[0] eq 'outfix_l';
		while((my $pos = index($$str_ref,$char)) >= 0)
			{
			_unicode_subchr($str_ref,$pos,$ops->{$char}[2].'(');#'_floor(');
			}
		}
	}

sub _infix
	{
	my ($ops,$str_ref) = @_;
	for my $char (keys %$ops)
		{
		next unless $ops->{$char}[0] eq 'infix';
		while((my $pos = index($$str_ref,$char)) >= 0)
			{
			my $front = _balance_parens($$str_ref,$pos-1,-1);
			_unicode_subchr($str_ref,$pos,',');
			substr($$str_ref,$front,0) = $ops->{$char}[2];#'_element';
			}
		}
	}

sub _prefix
	{
	my ($ops,$str_ref) = @_;
	for my $char (keys %$ops)
		{
		next unless $ops->{$char}[0] eq 'prefix';
		while((my $pos = index($$str_ref,$char)) >= 0)
			{
			_unicode_subchr($str_ref,$pos,$ops->{$char}[2]);#'_sigma');
			}
		}
	}

sub _postfix
	{
	my ($ops,$str_ref) = @_;
	for my $char (keys %$ops)
		{
		next unless $ops->{$char}[0] eq 'postfix';
		while((my $pos = index($$str_ref,$char)) >= 0)
			{
			my $front = _balance_parens($$str_ref,$pos-1,-1);
			_unicode_subchr($str_ref,$pos,'');
			substr($$str_ref,$front,0) = $ops->{$char}[2];#'_square';
			}
		}
	}

sub _balance_parens # Assume it's starting on the appropriate paren
	{
	my ($str,$pos,$dir) = @_;
	if($dir > 0)
		{
		my $balance = 1;
		$pos++ while substr($str,$pos,1) =~ /\s/;
		while($pos++ < length($str))
			{
			$balance++ if substr($str,$pos,1) eq '(';
			$balance-- if substr($str,$pos,1) eq ')';
			return $pos if $balance == 0;
			}
		return -1;
		}
	else
		{
		my $balance = 1;
		$pos-- while substr($str,$pos,1) =~ /\s/;
		while(--$pos > 0)
			{
			$balance-- if substr($str,$pos,1) eq '(';
			$balance++ if substr($str,$pos,1) eq ')';
			return $pos if $balance == 0;
			}
		return -1;
		}
	}

my $package;
BEGIN { $package = (caller(0))[0]; }; # Filter::Simple gets in the way here
use Filter::Simple;
FILTER_ONLY code => sub
	{
	shift @_;
	croak "Incorrect number of parameters\n" if @_ % 3;
	my $ops = _map_params(@_);
	my @lines = split /\n/;
	my $sym = 'aaaa';
	for(keys %$ops)
		{
		$ops->{$_}[2]='_'.$sym++;
		}
	{ no strict 'refs';
	use POSIX;
	for(keys %$ops)
		{
		*{$package.'::'.$ops->{$_}[2]}=$ops->{$_}[1];
		}
	};
	_outfix_r($ops,\$_);
	_outfix_l($ops,\$_);
	_infix($ops,\$_);
	_prefix($ops,\$_);
	_postfix($ops,\$_);
#die "<$_>\n";
	};

1;
__END__