File Coverage

blib/lib/Hustle/Table.pm

Criterion	Covered	Total	%
statement	64	66	96.9
branch	13	16	81.2
condition	4	6	66.6
subroutine	14	14	100.0
pod	0	4	0.0
total	95	106	89.6

package Hustle::Table;
use version; our $VERSION=version->declare("v0.6.0");

use strict;
use warnings;

use Template::Plex;

#use feature "refaliasing";
no warnings "experimental";

use Carp qw;



use constant DEBUG=>0;

#constants for entry fields
use enum (qw);

#Public API
#
sub new {
	my $class=shift//__PACKAGE__;
	my $default=shift//undef;
	bless [[undef,$default, "exact",1]],$class;	#Prefill with default handler
}

sub add {
	my ($self,@list)=@_;
	my $entry;
	my $rem;
	for my $item (@list){
		for(ref $item){
			if(/ARRAY/){
				#warn $item->$*;
				$entry=$item;
				croak "Incorrect number of items in dispatch vector. Should be 3" unless $entry->@* == 3;
			}

			elsif(/HASH/){
				$entry=[$item->@{qw}];
			}

			else{
				if(@list>=4){		#Flat hash/list key pairs passed in sub call
					my %item=@list;
					$entry=[@item{qw}];
					$rem =1;
				}
				elsif(@list==2){	#Flat list of matcher and sub. Assume regex
					# matcher=>sub
					$entry=[$list[0],$list[1],undef];
					$rem=1;
				}
				else{

				}
			}

		}

		#croak "matcher not specified" unless defined $entry->[matcher_];

		if(defined $entry->[matcher_]){
			#Append to the end of the normal matching list
			splice @$self, @$self-1,0, $entry;
		}
		else {
			#No matcher, thus this used as the default
			$self->set_default($entry->[value_]);
			#$self->[$self->@*-1]=$entry;
		}
		last if $rem;
	}
}


#overwrites the default handler.
sub set_default {
	my ($self,$sub)=@_;
	my $entry=[undef,$sub,"exact",1];
	$self->[@$self-1]=$entry;
}



sub prepare_dispatcher{
	my $self=shift;
	my %options=@_;
	my $cache=$options{cache}//{};
	$self->_prepare_online_cached($cache);
}

#
#Private API
#

sub _prepare_online_cached {
	my $table=shift; #self
	my $cache=shift;
	if(ref $cache ne "HASH"){
		carp "Cache provided isn't a hash. Using internal cache with no size limits";
		$cache={};
	}

	my $sub_template=
	'
	@{[do {
		my $do_capture;
		my $d="";

    my $pack=ref $item->[Hustle::Table::matcher_];
    my $is_regex;

    if($pack){
      $is_regex= ($pack eq "Regexp" or grep /^Regexp$/, @{$pack."::ISA"});
    }


		for($item->[Hustle::Table::type_]){
      if($is_regex){
			  $d.=\'($input=~$table->[\'. $index .\'][Hustle::Table::matcher_] )\';
				$do_capture=1;
      }
			elsif(ref($item->[Hustle::Table::matcher_]) eq "CODE"){

				$d.=\'($table->[\'.$index.\'][Hustle::Table::matcher_]->($input, ($table->[\'.$index.\'][1])))\';
			}
      elsif(/exact/){
				$d.=\'($input eq "\'. $item->[Hustle::Table::matcher_]. \'")\';
      }
      elsif(/begin/){
              $d.=\'(index($input, "\' . $item->[Hustle::Table::matcher_]. \'")==0)\';
      }
      elsif(/end/){
              $d.=\'(index(reverse($input), reverse("\'. $item->[Hustle::Table::matcher_].\'"))==0)\';
      }
      elsif(/numeric/){
              $d.=\'(\' . $item->[Hustle::Table::matcher_] . \'== $input)\';
      }
      else{
        #assume a regex - even if a basic string
				$item->[Hustle::Table::matcher_]=qr{$item->[Hustle::Table::matcher_]};
				$item->[Hustle::Table::type_]=undef;
				$do_capture=1;
				$d.=\'($input=~m{\' . $item->[Hustle::Table::matcher_].\'})\';
                        }
		}


		if($do_capture){
			$d.=\' and return ($cache->{$input}=$table->[\'.$index.\'], [@{^CAPTURE}]);\';
		}
		else {
			$d.=\' and return ($cache->{$input}=$table->[\'.$index.\']);\';

		}
		$d;
	}]}
	';

	my $template=
	'
	my \$input;
	my \$entry;
  no warnings "numeric";
	sub {
		\$input=shift;
		\$entry=\$cache->{\$input};
		#Locate cached regex types, perform capture, and return
		#Locate cached non regex types and return
		#\$entry
			\$entry->[Hustle::Table::type_]
			? return \$entry
			: (\$input=~ \$entry->[Hustle::Table::matcher_])
				and return (\$entry, [\@{^CAPTURE}])


			if \$entry;


		#Build the logic for matcher entry in order of listing
		@{[do {
			my $index=0;
			my $base={index=>0, item=>undef};
			my $sub=$self->load([$sub], $base);
			map {
				$base->{index}=$_;
				$base->{item}=$table->[$_];
				my $s=$sub->render;
				$s;
			} 0..$table->@*-2;
		}]}


		#If we get here we cache and return the default matcher
		\$cache->{\$input}=\$table->[\@\$table-1];
	} ';

	my $top_level=Template::Plex->load([$template],{table=>$table, cache=>$cache, sub=>$sub_template});
	my $s=$top_level->render;
	#say STDERR $s;
	#my $line=1;
	#print map $_."\n", split "\n", $s;
	my $ss=eval $s;
	#print $@;
	$ss;
}

1;
__END__