File Coverage

blib/lib/Dotiac/DTL/Addon/case_insensitive.pm

Criterion	Covered	Total	%
statement	89	122	72.9
branch	31	76	40.7
condition	11	30	36.6
subroutine	10	10	100.0
pod	1	2	50.0
total	142	240	59.1

###############################################################################
#case-insensitive.pm
#Last Change: 2009-02-09
#Copyright (c) 2009 Marc-Seabstian "Maluku" Lucksch
#Version 0.4
####################
#This file is an addon to the Dotiac::DTL project.
#http://search.cpan.org/perldoc?Dotiac::DTL
#
#case-insensitive.pm is published under the terms of the MIT license, which
#basically means "Do with it whatever you want". For more information, see the
#license.txt file that should be enclosed with this distribution. A copy of
#the license is (at the time of writing) also available at
#http://www.opensource.org/licenses/mit-license.php .
###############################################################################


package Dotiac::DTL::Addon::case_insensitive;
use strict;
use warnings;

#If it is not already loaded.
require Dotiac::DTL::Core;

our $VERSION=0.4;

my $old;

our %keymap=();

sub import {
	no warnings qw/redefine/;
	$old = \&Dotiac::DTL::devar_var;
	*Dotiac::DTL::devar_var=\&devar_var;

}
sub unimport {
	no warnings qw/redefine/;
	*Dotiac::DTL::devar_var = $old;
}

sub devar_var {
	my $name=shift;
	my $n=$name;
	return Dotiac::DTL::Value->safe(undef) unless defined $name;
	my $lcn = lc($name);
	my $param=shift;
	my $f=substr $name,0,1;
	my $l=substr $name,-1,1;
	my $escape=shift;

	return Dotiac::DTL::Value->safe(substr $name,1,-1) if $f eq "'" and $l eq "'" or $f eq '"' and $l eq '"';
	return Dotiac::DTL::Value->safe(Dotiac::DTL::descap(substr $name,1,-1)) if $f eq "`" and $l eq "`";

	if ($lcn eq "block.super" and $param->{"block.super"}) {
		return Dotiac::DTL::Value->safe($param->{"block.super"}->string($param,@_)) if Scalar::Util::blessed($param->{"block.super"});
		return Dotiac::DTL::Value->safe($param->{"block.super"}->($param,@_)) if ref $param->{"block.super"} eq "CODE";
	}
	return Dotiac::DTL::Value->new($param->{$name},!$escape) if exists $param->{$name};
	return Dotiac::DTL::Value->new($param->{$Dotiac::DTL::Addon::case_insensitive::keymap{$lcn}},!$escape) if defined $Dotiac::DTL::Addon::case_insensitive::keymap{$lcn} and exists($param->{$Dotiac::DTL::Addon::case_insensitive::keymap{$lcn}});
	foreach my $k (keys %{$param}) {
		if (lc($k) eq $lcn) {
			$Dotiac::DTL::Addon::case_insensitive::keymap{$lcn}=$k;
			return Dotiac::DTL::Value->new($param->{$k},!$escape);
		}
	}
	my @tree=split/\./,$name;
	$name=shift @tree;
	$lcn = lc($name);
	if (exists $param->{$name}) {
		$param=$param->{$name};
	}
	elsif (defined $Dotiac::DTL::Addon::case_insensitive::keymap{$lcn} and exists $param->{$Dotiac::DTL::Addon::case_insensitive::keymap{$lcn}}) {
		$param=$param->{$Dotiac::DTL::Addon::case_insensitive::keymap{$lcn}};
	}
	else {
		my $found=0;
		foreach my $k (keys %$param) {
			if (lc($k) eq $lcn) {
				$Dotiac::DTL::Addon::case_insensitive::keymap{$lcn}=$k;
				$found=1;
				$param=$param->{$k};
				last;
			}
		}
		unless ($found) {
			return Dotiac::DTL::Value->safe($n) if $n!~/[^\d\-\.\,\e]/;
			foreach my $k (keys %Dotiac::DTL::cycle) {
				if (lc($k) eq $lcn and $Dotiac::DTL::cycle{$k}->[1]) {
					return Dotiac::DTL::Value->safe("") if $Dotiac::DTL::included{"cycle_$k"}++;
					my $r=devar_raw($Dotiac::DTL::cycle{$k}->[2]->[$Dotiac::DTL::cycle{$k}->[0]-1 % $Dotiac::DTL::cycle{$k}->[1]],$param,$escape,@_);
					$Dotiac::DTL::included{"cycle_$k"}=0;
					return $r;
				}
			}
			return Dotiac::DTL::Value->safe(undef) ;
		}
	}
	while (defined(my $name = shift @tree)) {
		$lcn = lc($name);
		my $r = Scalar::Util::reftype($param);
		if ($r) {
			if ($r eq "HASH") {
				if (not exists $param->{$name}) {
					my $found=0;
					foreach my $k (keys %{$param}) {
						if (lc($k) eq $lcn) {
							$found=1;
							$param=$param->{$k};
							last;
						}
					}
					next if $found;
					return Dotiac::DTL::Value->safe(undef) unless Scalar::Util::blessed($param);
				}
				else {
					$param=$param->{$name};
					next;
				}
			}
			elsif ($r eq "ARRAY") {
				if ($name=~m/\D/) {
					return Dotiac::DTL::Value->safe(undef) unless Scalar::Util::blessed($param);
				}
				else {
					if (not exists $param->[$name]) {
						return Dotiac::DTL::Value->safe(undef) unless Scalar::Util::blessed($param);
					}
					else {
						$param=$param->[$name];
						next;
					}
				}
			}
		}
		if (Scalar::Util::blessed($param)) {
			return Dotiac::DTL::Value->safe(undef) unless $Dotiac::DTL::ALLOW_METHOD_CALLS;
			my $found=0;
			foreach my $k ($param->dotiac_get_all_methods()) {
				if (lc($k) eq $lcn) {
					$found=1;
					$param=$param->$k();
					last;
				}
			}
			if (not $found and $param->can("__getitem__")) {
				my $x;
				eval {
					$x=$param->__getitem__($name);
					1;
				} or return Dotiac::DTL::Value->safe(undef);
				if (defined $x) {
					$param=$x;
					next;
				}
			}
			return Dotiac::DTL::Value->safe(undef) unless $found;
			next;
		}
		return Dotiac::DTL::Value->safe($n) if $n!~/[^\d\-\.\,\e]/;
		return Dotiac::DTL::Value->safe(undef);
	}
	return Dotiac::DTL::Value->new($param,!$escape);
}


package UNIVERSAL;

use strict;

sub dotiac_get_all_methods {
	my ($class, undef) = @_;
	$class = ref $class || $class;
	my %classes_seen;
	my %methods;
	my @class = ($class);

	no strict 'refs';
	while ($class = shift @class) {
	    next if $classes_seen{$class}++;
	    unshift @class, @{"${class}::ISA"};
	    # Based on methods_via() in perl5db.pl
	    for my $method (grep { # not /^[(_]/ and  # Has to be removed, sadly
				  defined &{${"${class}::"}{$_}}}
			    keys %{"${class}::"}) {
		$methods{$method} = wantarray ? undef : $class->can($method);
	    }
	}

	wantarray ? keys %methods : \%methods;
}

1;

__END__