File Coverage

blib/lib/Dotiac/DTL/Core.pm

Criterion	Covered	Total	%
statement	233	302	77.1
branch	80	156	51.2
condition	20	48	41.6
subroutine	21	25	84.0
pod	17	17	100.0
total	371	548	67.7

###############################################################################
#Core.pm
#Last Change: 2009-01-19
#Copyright (c) 2009 Marc-Seabstian "Maluku" Lucksch
#Version 0.8
####################
#This file is part of the Dotiac::DTL project.
#http://search.cpan.org/perldoc?Dotiac::DTL
#
#Core.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 libsofu distributions. 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::Core;

our $VERSION = 0.8;

package Dotiac::DTL;
require Dotiac::DTL::Value;
require Dotiac::DTL::Template;
require Dotiac::DTL::Filter;
require Dotiac::DTL::Compiled;

use strict;
use warnings;
use Scalar::Util qw/reftype blessed/;
use Carp;
require File::Spec;
require File::Basename;

#These go into the context.
our $TEMPLATE_STRING_IF_INVALID=""; #If there was no parameter found
our $ALLOW_METHOD_CALLS=1;
our $ALLOWED_INCLUDE_ROOTS=0; #Allows the ssi tag
our $AUTOESCAPING=1; #Default auto escape or not
our $DATETIME_FORMAT='N j, Y, P';
our $DATE_FORMAT='N j, Y';
our $TIME_FORMAT='P';
our @TEMPLATE_DIRS=(); #Only used by Template();
our $Max_Depth=3;
our $CURRENTDIR="";
our $PARSER="Dotiac::DTL::Parser";

#This has to change someday. not global
our %blocks; #this needs to be global, sadly.
our %cycle; #Also needs to be global.
our %globals; #Well we already have other globals, this saves me the init() trough the whole tree/list.


our %included;
our %params;


# Template cache, needs to be global
my %cache;

sub new {
	my $class=shift;
	my $data=shift;
	my $t="";
	%params=();
	if (ref $data eq "SCALAR") {
		die "Dotiac::DTL::Reduced can only work with compiled templates, use Dotiac::DTL for the full interface";
	}
	elsif (not ref $data) {
		$t=$data;
		my @f = File::Basename::fileparse($data);
		$Dotiac::DTL::currentdir=$f[1];
		if (-e "$data.pm") {
			if ($cache{"$data.pm"} and exists $cache{"$data.pm"}->{changetime} and $cache{"$data.pm"}->{changetime} < (stat("$data.pm"))[9]) {
				carp "Foo";
				delete $cache{"$data.pm"};
				delete $INC{"$data.pm"};
			}
			if (-e $data) {
				if ((stat("$data.pm"))[9] >= (stat("$data"))[9]) {
					eval {
						$cache{"$data.pm"}={
							template=>Dotiac::DTLCompiled->new("Dotiac::DTL::Compiled::".require "$data.pm"),
							currentdir=>$Dotiac::DTL::currentdir,
							params=>{%Dotiac::DTL::params},
							parser=>$Dotiac::DTL::PARSER,
							changetime=>(stat("$data.pm"))[9]
						} if not $cache{"$data.pm"};# or (exists $cache{"$data.pm"}->{changetime} and $cache{"$data.pm"}->{changetime} > -M "$data.pm"); #Can't do it, Require won't return the filename a second time, has to be solved differently by manually modifing %INC
						$t="$data.pm";
						1;
					} or do {
						croak "Error while getting compiled template $data.pm and can't use $data, because this is Reduced:\n $@\n.";
						undef $@;
					};
				}
				else {
					carp "$data seem to outdate $data.pm, but Dotiac::DTL::Reduced can only work with compiled templates, use Dotiac::DTL to recompile";
					eval {
						$cache{"$data.pm"}={
							template=>Dotiac::DTLCompiled->new("Dotiac::DTL::Compiled::".require "$data.pm"),
							currentdir=>$Dotiac::DTL::currentdir,
							params=>{%Dotiac::DTL::params},
							parser=>$Dotiac::DTL::PARSER,
							changetime=>(stat("$data.pm"))[9]
						} if not $cache{"$data.pm"};# or (exists $cache{"$data.pm"}->{changetime} and $cache{"$data.pm"}->{changetime} > -M "$data.pm");
						$t="$data.pm";
						1;
					} or do {
						croak "Error while getting compiled template $data.pm and can't use $data, because this is Reduced:\n $@\n.";
						undef $@;
					};
				}
			}
			else {
				eval {
					$cache{"$data.pm"}={
						template=>Dotiac::DTL::Compiled->new("Dotiac::DTL::Compiled::".require "$data.pm"),
						currentdir=>$Dotiac::DTL::currentdir,
						params=>{%Dotiac::DTL::params},
						parser=>$Dotiac::DTL::PARSER,
						changetime=>(stat("$data.pm"))[9]
					} if not $cache{"$data.pm"};# or (exists $cache{"$data.pm"}->{changetime} and $cache{"$data.pm"}->{changetime} > -M "$data.pm");
					$t="$data.pm";
					1;
				} or do {
					croak "Error while getting compiled template $data.pm and $data is gone:\n $@\n.";
					undef $@;
				};
			}
		}
		unless ($cache{$t})  {
			croak "Dotiac::DTL::Reduced can only work with compiled templates, use Dotiac::DTL for the full interface";
		}
	}
	else {
		die "Can't work with $data!";
	}
	#$self->{data}=$data;
	Dotiac::DTL::Addon::restore();
	if ($cache{$t}) {
		return "Dotiac::DTL::Template"->new($cache{$t}->{template},$cache{$t}->{currentdir},$cache{$t}->{parser},$cache{$t}->{params});
	}
	else {
		croak "Dotiac::DTL::Reduced can only work with compiled templates, use Dotiac::DTL for the full interface";
	}
}

our $currentdir="";

sub safenew {
	my $class=shift;
	my $file=shift;
	unless ($ALLOWED_INCLUDE_ROOTS and int($ALLOWED_INCLUDE_ROOTS) > 2) {
		$file=~s/^[\\\/]//g;
		$file=~s/^\w+\://g; #Windows GRR
		1 while $file=~s/^\.\.[\\\/]//g;
	}
	unless ( -e $file or -e "$file.pm") {
		my $rfile=File::Spec->catfile(".",$currentdir,$file);
		return Dotiac::DTL->new($rfile) if -e $rfile or -e "$rfile.pm";
	}
	my $p=$Dotiac::DTL::PARSER;
	my $r=Dotiac::DTL->new($file);
	$Dotiac::DTL::PARSER=$p;
	return $r;
}

sub compiled {
	my $class=shift;
	my $name=shift;
	my $f;
	$Dotiac::DTL::currentdir=$Dotiac::DTL::CURRENTDIR;
	%params=();
	eval {
		$f=Dotiac::DTL::Compiled->new($name);
		1;
	} or do {
		croak "Error while getting compiled template from $name\n $@\n.";
		undef $@;
	};
	undef $@;
	return "Dotiac::DTL::Template"->new($f,$Dotiac::DTL::CURRENTDIR);
}



sub urlencode {
	my $val=shift;
	$val = eval { pack("C*", unpack("U0C*", $val))} || pack("C*", unpack("C*", $val));
	$val=~s/([^a-zA-Z0-9_.~-])/uc sprintf("%%%02x",ord($1))/eg;
	return $val;
}

sub escap { #Escape is used too much these days.
	my $string=shift;
	$string=~s/\\n/\n/g;
	$string=~s/\\t/\t/g;
	$string=~s/\\r/\r/g;
	$string=~s/\\b/\b/g;
	$string=~s/\\f/\f/g;
	$string=~s/\\x([\dA-Fa-f]{2})/chr(hex($1))/eg;
	$string=~s/\\u([\dA-Fa-f]{4})/chr(hex($1))/eg;
	$string=~s/\\U([\dA-Fa-f]{8})/chr(hex($1))/eg;
	$string=~s/\\(["'{}])/$1/g;
	#$string=~s/\\([^\\])/die/eg;
	$string=~s/\\\\/\\/g;
	#TODO more pyhton escape seq.
	$string=~s/([\|\s\,\"\'\`\%\:;=])/sprintf("%%%02X",ord($1))/eg;
	return "`$string`";
}

sub descap {
	my $string=shift;
	$string=~s/%([\da-fA-F]{2})/chr(hex($1))/eg;
	return $string;
}

sub get_variables {
	my $x=shift;
	$x="" if not defined $x or ref $x;
	while ($x=~m/[^\"\']*([\"\'])/g) {
		my $opos=pos($x);
		if ($1 eq '"') {
			$x=~m/((?>(?:(?>[^"\\]+)|\\.)*))"/g;
			die "Syntax error in $1..$1 of $x" unless pos($x);
			my $replace=escap($1);
			substr($x,$opos-1,pos($x)+1-$opos)=$replace;
			pos($x)=$opos+length($replace);
		}
		else {
			$x=~m/((?>(?:(?>[^'\\]+)|\\.)*))'/g;
			die "Syntax error in $1..$1 of $x" unless pos($x);
			my $replace=escap($1);
			substr($x,$opos-1,pos($x)+1-$opos)=$replace;
			pos($x)=$opos+length($replace);
		}
		die "Syntax error in $1..$1 of $x" unless pos($x);
	}
	#warn "var::$x";
	if (@_) {
		my %words;
		@words{@_}=(1) x scalar @_;
		my %ret;
		my $keywords = "(?:^|\\s+)".join ("(?:\\s+|\$)|(?:^|\\s+)",@_)."(?:\\s+|\$)";
		#print STDERR "@_: $keywords\n";
		my @l = split /($keywords)/,$x;
		#print STDERR join(", ",@l)."\n";
		unshift @l,"";
		while (defined(my $k=shift @l)) {
			$k=~s/^\s+//g;
			$k=~s/\s+$//g;
			if (@l) {
				my $next=$l[0];
				$next=~s/^\s+//g;
				$next=~s/\s+$//g;
				if ($words{$next}) {
					$ret{$k}=[];
				}
				else {
					my @a=split /\s+/,shift(@l);
					$ret{$k}=[@a];
					foreach my $a (@a) {
						$Dotiac::DTL::params{$a}++;
					}
				}
			}
			else {
				$ret{$k}=[];
			}
		}
		return %ret;
	}
	my @a= split /\s+/,$x;
	foreach my $a (@a) {
		$Dotiac::DTL::params{$a}++;
	}
	return @a;
}

sub Escape {
	my $var=shift;
	return Dotiac::DTL::Value->escape($var)->string() if $_[0];
	return $var;
}

sub Conditional {
	my $var=shift;
	return "" unless $var;
	return $var unless ref $var;
	return $var->count() if Scalar::Util::blessed($var) and $var->can("count");
	return 1 if Scalar::Util::blessed($var);
	return scalar @{$var} if ref $var eq "ARRAY";
	return scalar keys %{$var} if ref $var eq "HASH";
	return 1;
}

sub apply_filters {
	my $value=shift;
	my $vars=shift;
	my $escape=shift;
	#$escape=0 if $STRING_IS_LITERAL; #TODO
	#$VARIABLE_IS_SAFE=!$escape;
	unless (Scalar::Util::blessed($value) and $value->isa("Dotiac::DTL::Value")) {
		$value=Dotiac::DTL::Value->new($value,!$escape);
	}
	foreach my $f (@_) {
		my ($filter,$param)=split /:/,$f,2;
		$filter=lc $filter;
		eval {
			no strict "refs"; #I hate to do this, does anyone know a better one without eval?
			$value="Dotiac::DTL::Filter::$filter"->($value,defined $param?(map {devar_var($_,$vars,0)} split /[,;]/,$param):());
		};
		if ($@) {
			die "Filter '$filter' couldn't be found or an error occoured. The filter has to be in the Dotiac::DTL::Filter namespace\n$@";
		}
		die "Filter Error: $filter did not return a Dotiac::DTL::Value" unless Scalar::Util::blessed($value) and $value->isa("Dotiac::DTL::Value");
	}
	return $value;
}

sub devar {
	my $name=shift;
	return "" unless defined $name;
	my @data= split/\|/,$name;
	$name=shift @data;
	my $param=shift;
	my $escape=shift;
	my $var=devar_var($name,$param,$escape,@_);
	unless (@data) {
		return $var->string();
	}
	$var=apply_filters($var,$param,$escape,@data);
	return $var->string();

}

sub devar_nodefault {
	my $name=shift;
	return "" unless defined $name;
	my @data= split/\|/,$name;
	$name=shift @data;
	my $param=shift;
	my $escape=shift;
	my $var=devar_var($name,$param,$escape,@_);
	unless (@data) {
		return $var->stringnodefault();
	}
	$var=apply_filters($var,$param,$escape,@data);
	return $var->stringnodefault();

}

sub devar_raw {
	my $name=shift;
	return "" unless defined $name;
	my @data= split/\|/,$name;
	$name=shift @data;
	my $param=shift;
	my $escape=shift;
	my $var=devar_var($name,$param,$escape,@_);
	unless (@data) {
		return $var;
	}
	$var=apply_filters($var,$param,$escape,@data);
	return $var;

}

sub devar_content {
	my $name=shift;
	return "" unless defined $name;
	my @data= split/\|/,$name;
	$name=shift @data;
	my $param=shift;
	my $escape=shift;
	my $var=devar_var($name,$param,$escape,@_);
	unless (@data) {
		use Carp qw/confess/;
		confess unless ref $var;
		return $var->content();
	}
	$var=apply_filters($var,$param,$escape,@data);
	return $var->content();

}

sub devar_repr {
	my $name=shift;
	return "" unless defined $name;
	my @data= split/\|/,$name;
	$name=shift @data;
	my $param=shift;
	my $escape=shift;
	my $var=devar_var($name,$param,$escape,@_);
	unless (@data) {
		use Carp qw/confess/;
		confess unless ref $var;
		return $var->repr();
	}
	$var=apply_filters($var,$param,$escape,@data);
	return $var->repr();

}

sub devar_var {
	my $name=shift;
	my $n=$name;
	return Dotiac::DTL::Value->safe(undef) unless defined $name;
	my $param=shift;
	my $f=substr $name,0,1;
	my $l=substr $name,-1,1;
	my $escape=shift;
	#TODO
	use Carp;
	confess $param unless ref $param;
	confess $escape unless defined $escape;
	#confess @_ unless @_;
	#TODO
	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(descap(substr $name,1,-1)) if $f eq "`" and $l eq "`";
	if ($name 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};
	my @tree=split/\./,$name;
	$name=shift @tree;
	unless (exists $param->{$name}) {
		return Dotiac::DTL::Value->safe($n) if $n!~/[^\d\-\.\,\e]/;
		if ($cycle{$name} and $cycle{$name}->[1]) {
			return Dotiac::DTL::Value->safe("") if $included{"cycle_$name"}++;
			my $r=devar_raw($cycle{$name}->[2]->[$cycle{$name}->[0]-1 % $cycle{$name}->[1]],$param,$escape,@_);
			$included{"cycle_$name"}=0;
			return $r;
		}
		return Dotiac::DTL::Value->safe(undef) ;
	}
	$param=$param->{$name};
	while (defined(my $name = shift @tree)) {
		my $r = reftype $param;
		if ($r) {
			if ($r eq "HASH") {
				if (not exists $param->{$name}) {
					return Dotiac::DTL::Value->safe(undef) unless blessed $param;
				}
				else {
					$param=$param->{$name};
					next;
				}
			}
			elsif ($r eq "ARRAY") {
				if ($name=~m/\D/) {
					return Dotiac::DTL::Value->safe(undef) unless blessed $param;
				}
				else {
					if (not exists $param->[$name]) {
						return Dotiac::DTL::Value->safe(undef) unless blessed $param;
					}
					else {
						$param=$param->[$name];
						next;
					}
				}
			}
		}
		if (blessed $param) {
			return Dotiac::DTL::Value->safe(undef) unless $ALLOW_METHOD_CALLS;
			if ($param->can($name)) {
				$param=$param->$name();
				next;
			}
			elsif ($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);
		}
		return Dotiac::DTL::Value->safe($n) if $n!~/[^\d\-\.\,\e]/;
		return Dotiac::DTL::Value->safe(undef);
	}
	return Dotiac::DTL::Value->new($param,!$escape);
}

sub devar_var_default {
	my $var = devar_var(@_);
	return $var->string();
}

1;
__END__