File Coverage

Qtpl.pm

Criterion	Covered	Total	%
statement	146	247	59.1
branch	29	86	33.7
condition	1	3	33.3
subroutine	14	32	43.7
pod	14	27	51.8
total	204	395	51.6

package Template::Qtpl;

###########################################################################
# Copyright (c) 2000 barnabÓs debreceni [[e-mail]]
#     Original PHP version.
#
# Copyright(c) 2000-2001 Alexey Presnyakov [[e-mail]]
#	  Perl port and extension.
#
# This library is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# $Author: alexey_pres $, $Date: 2001/10/18 09:39:24 $
# $Revision: 1.2 $
###########################################################################


use strict;
use Carp;
use File::Basename;

$Template::Qtpl::VERSION = '0.5';
$Template::Qtpl::file_delim = "\{FILE\s*\"(.+?)\"\s*\}";
$Template::Qtpl::block_start_delim = '';
$Template::Qtpl::block_start_word = 'BEGIN:';
$Template::Qtpl::block_end_word = 'END:';
$Template::Qtpl::var_begin = '{';
$Template::Qtpl::var_end = '}';


############################ variable set functions ################
sub block_start_delim {
	my ($v) = shift;
	my $ret;
	$v = shift if ((ref $v) eq 'Template::Qtpl');
	$ret = $Template::Qtpl::block_start_delim;
	$Template::Qtpl::block_start_delim = $v if (length $v);
	return $ret;
}

sub block_end_delim {
	my ($v) = shift;
	my $ret;
	$v = shift if ((ref $v) eq 'Template::Qtpl');
	$ret = $Template::Qtpl::block_end_delim;
	$Template::Qtpl::block_end_delim = $v if (length $v);
	return $ret;
}

sub block_start_word {
	my ($v) = shift;
	my $ret;
	$v = shift if ((ref $v) eq 'Template::Qtpl');
	$ret = $Template::Qtpl::block_start_word;
	$Template::Qtpl::block_start_word = $v if (length $v);
	return $ret;
}

sub block_end_word {
	my ($v) = shift;
	my $ret;
	$v = shift if ((ref $v) eq 'Template::Qtpl');
	$ret = $Template::Qtpl::block_end_word;
	$Template::Qtpl::block_end_word = $v if (length $v);
	return $ret;
}

sub var_begin {
	my ($v) = shift;
	my $ret;
	$v = shift if ((ref $v) eq 'Template::Qtpl');
	$ret = $Template::Qtpl::var_begin;
	$Template::Qtpl::block_start_word = $v if (length $v);
	return $ret;
}

sub var_end {
	my ($v) = shift;
	my $ret;
	$v = shift if ((ref $v) eq 'Template::Qtpl');
	$ret = $Template::Qtpl::var_end;
	$Template::Qtpl::block_end_word = $v if (length $v);
	return $ret;
}

sub file_delim {
	my ($v) = shift;
	my $ret;
	$v = shift if ((ref $v) eq 'Template::Qtpl');
	$ret = $Template::Qtpl::file_delim;
	$Template::Qtpl::file_delim = $v if (length $v);
	return $ret;
}

############################ new ###################################
sub new {
	my $class = shift;
	my $self = {};
	bless $self, $class;
	$self->init(@_);
	return $self;
}
############################## init ################################
sub init {
	my $self = shift;
	my ($filename, $mainblock) = @_;
##### set vars
	$self->{filecontents} = '';
	$self->{blocks} = {};
	$self->{parsed_blocks} = {};
	$self->{block_parse_order} = [];
	$self->{sub_blocks} = {};
	$self->{VARS} = {};
#this makes the delimiters look like:  if you use my syntax.
    $self->{NULL_STRING} = {''=>''};
	$self->{NULL_BLOCK} = {''=>''};
	$self->{mainblock} = '';
	$self->{ERROR} = '';
	$self->{AUTORESET} = 1;
####### init variables
    $self->{mainblock} = $mainblock;
	$self->{FILENAME} = $filename;
	$self->{filecontents} = $self->r_getfile($filename);
	$self->{blocks} = $self->maketree($self->{filecontents}, $mainblock);
	$self->scan_globals();
	return $self;
}

sub assign {
	my $self = shift;
	my ($k, $v);
	while (scalar(@_)){
		$k = shift;
		$v = shift;
		$self->{VARS}{$k} = $v;
	}
}

sub get_var{
	my $self = shift;
	my $v = shift; #variable name for subst
        my $need_encode = 0;
	if ($v =~ /^\~(.+)$/){
	        $v = $1;
	        $need_encode = 1;
	}
	my @sub = split(/\./,$v);
	my $var;
	if ($sub[0] =~ /^main::(.+)$/){
		no strict;
		my $varname = $sub[0];
		if (scalar(@sub)>1) {
			$var = \%$varname;
			shift @sub;
			goto FROM_GLOBALS;
		} else {
			$var = $$varname;
		}
	} else {
		$var=$self->{VARS};
FROM_GLOBALS:
		my $sv;
		foreach $sv (@sub){
				$var = $var->{$sv};
		}
	}
        if ($need_encode) {
        	$var =~ s/\"/\"/g;
	}
	return $var;
}

sub _if_subst {
	my $self = shift;
	my ($if, $body) = @_;
	my $if_val = $self->get_var($if);
	my @parts = split(/$Template::Qtpl::var_begin[E]LSE$Template::Qtpl::var_end/, $body);
	if (length $if_val) {
		return $parts[0];
	} else {
		return $parts[1];
	}
}

sub parse {
	my $self = shift;
	my ($bname) = @_;
	my $copy = $self->{blocks}->{$bname};

	$self->set_error("parse: blockname [$bname] does not exist")
		unless (defined($self->{blocks}->{$bname}));

        while ($self->{blocks}->{$bname} =~
        		/$Template::Qtpl::var_begin([\~\w\.\:]+)$Template::Qtpl::var_end/g) {
		my $v = $1;
		next if ($v =~ /^IF\s+/);
		next if ($v =~ /^(ELSE|ENDIF)$/);
		if ($v =~ /^_BLOCK_\.(.+)$/) {
			my $bname2=$1;
			my $var=$self->{parsed_blocks}->{$bname2};
			my $nul=(!exists($self->{NULL_BLOCK}->{$bname2})) ?
				$self->{NULL_BLOCK}{''} :
				$self->{NULL_BLOCK}->{$bname2};
			$var=(!defined($var))?$nul:$var;
			$copy =~ s/$Template::Qtpl::var_begin$v$Template::Qtpl::var_end/$var/eg;
		} else {
			my $var = $self->get_var($v);
			my $nul=(!exists($self->{NULL_STRING}{$v})) ?
				$self->{NULL_STRING}{''} :
				$self->{NULL_STRING}{$v};
			$var=(!length($var))?$nul:$var;
			$copy =~ s/$Template::Qtpl::var_begin$v$Template::Qtpl::var_end/$var/eg
				unless ($v =~ /^\d/);
		}
	}
# parse if tags
	$copy =~ s/$Template::Qtpl::var_begin[I]F\s+(.+?)\s*$Template::Qtpl::var_end(.*?)$Template::Qtpl::var_begin[E]NDIF$Template::Qtpl::var_end/$self->_if_subst($1, $2)/egs;

	my ($bname_new) = split(/\:/, $bname);
#save as to parsed
	$self->{parsed_blocks}->{$bname_new}.=$copy;
#reset sub-blocks
	my ($bname3);
	if ($self->{AUTORESET}) {
		if (exists($self->{sub_blocks}->{$bname_new})) {
			foreach $bname3 (@{$self->{sub_blocks}->{$bname_new}}){
				next unless length ($bname_new);
				$self->reset($bname3);
			}
		}
	}
}

#***[ rparse ]**************************************************************/
#* returns the parsed text for a block, including all sub-blocks.
sub rparse {
	my $self = shift;
	my $bname = shift;
	if (exists($self->{sub_blocks}->{$bname})) {
		my ($bname3);
		foreach $bname3 (@{$self->{sub_blocks}->{$bname}}){
			next if (!length $bname3);
			$self->rparse($bname3);
		}
	}
	$self->parse($bname);
}

#***[ text ]****************************************************************/
#* returns the parsed text for a block
sub text {
	my $self = shift;
	my ($bname) = @_;
	if (!length($bname))  {
		$bname=$self->{mainblock};
	}
	return $self->{parsed_blocks}->{$bname};
}

#/***[ out ]*****************************************************************/
#/* prints the parsed text
sub out {
	my $self = shift;
	my ($bname) = @_;
	print $self->text($bname);
}

#/***[ reset ]***************************************************************/
#/* resets the parsed text
sub reset  {
	my $self = shift;
	my ($bname) = @_;
	$self->{parsed_blocks}->{$bname}='';
}

#***[ parsed ]**************************************************************/
#* returns true if block was parsed, false if not
sub parsed  {
	my $self = shift;
	my ($bname) = @_;
	return (defined($self->{parsed_blocks}->{$bname}));
}

#***[ SetNullString ]*******************************************************/
#* sets the string to replace in case the var was not assigned
sub SetNullString {
	my $self = shift;
	my ($str, $varname) = @_;
	$self->{NULL_STRING}{$varname}=$str;
}

#***[ SetNullBlock ]********************************************************/
#* sets the string to replace in case the block was not parsed
sub SetNullBlock {
	my $self = shift;
	my ($str, $bname) = @_;
	$self->{NULL_BLOCK}{$bname}=$str;
}

#***[ set_autoreset ]*******************************************************/
#*	sets AUTORESET to 1. (default is 1)
#	if set to 1, parse() automatically resets the parsed blocks' sub blocks
#	(for multiple level blocks)
sub set_autoreset {
	my $self = shift;
	$self->{AUTORESET}=1;
}

#/***[ clear_autoreset ]*****************************************************/
#/*
#	sets AUTORESET to 0. (default is 1)
#	if set to 1, parse() automatically resets the parsed blocks' sub blocks
#	(for multiple level blocks)
sub clear_autoreset {
	my $self = shift;
	$self->{AUTORESET}=0;
}

#/***[ scan_globals ]********************************************************/
#/*
#	scans global variables
#*/
sub scan_globals {
	my $self = shift;
	$self->assign("PHP",\%ENV);
	#* access global variables as {ENV.HTTP_HOST} in your template! */
}

#/******
#
#		WARNING
#		PUBLIC FUNCTIONS BELOW THIS LINE DIDN'T GET TESTED
#
#******/


#/***************************************************************************/
#/***[ private stuff ]*******************************************************/
#/***************************************************************************/
#/***[ maketree ]************************************************************/
#/*
#	generates the array containing to-be-parsed stuff:
#  $blocks["main"],$blocks["main.table"],$blocks["main.table.row"], etc.
#	also builds the reverse parse order.
#*/
sub maketree {
	my $self = shift;
	my ($con, $block) = @_;
	my @con2=split($Template::Qtpl::block_start_delim,$con);
	my $level=0;
	my @block_names = ('');
	my %blocks=();
	my $parent_name;
	my ($k,$v, @res);
	my %added_to_parent = ();
	foreach $v (@con2){
		my $patt="($Template::Qtpl::block_start_word|$Template::Qtpl::block_end_word)\\s*([\\w\\.\\:]+)\\s*$Template::Qtpl::block_end_delim(.*)";
		if ($v =~ /$patt/is) {
			# $res[1] = BEGIN or END
			# $res[2] = block name
			# $res[3] = kinda content
			$res[1] = $1;
			$res[2] = $2;
			$res[3] = $3;
			if ($res[1] eq $Template::Qtpl::block_start_word) {
				$parent_name=@block_names ? join(".", @block_names) : '';
				$parent_name =~ s/^\.//; #hack
				$block_names[++$level ] = $res[2];
				#/* add one level - array("main","table","row")*/
				my @block_nm = @block_names;
				shift @block_nm;
				my $cur_block_name=join(".",@block_nm);
					#/* make block name (main.table.row) */
				push @{$self->{block_parse_order}}, $cur_block_name;
					#/* build block parsing order (reverse) */
				$blocks{$cur_block_name}.=$res[3];

				my ($cur_block_name_new) = split(/\:/, $cur_block_name);
					#/* add contents */
					#/* add {_BLOCK_.blockname} string to parent block */
				if (!$added_to_parent{$cur_block_name_new}) {
					$blocks{$parent_name}.=$Template::Qtpl::var_begin."_BLOCK_.$cur_block_name_new".$Template::Qtpl::var_end;
					#/* store sub block names for autoresetting
					# and recursive parsing */
					push @{$self->{sub_blocks}->{$parent_name}},
							$cur_block_name_new;
					#/* store sub block names for autoresetting */
					push @{$self->{sub_blocks}->{$cur_block_name_new}},'';
				}
				$added_to_parent{$cur_block_name_new}++;
			} elsif ($res[1] eq $Template::Qtpl::block_end_word) {
				splice(@block_names, $level--, 1);
				$parent_name=join(".",@block_names);
				$parent_name =~ s/^\.//; #hack
				$blocks{$parent_name}.=$res[3];
					#/* add rest of block to parent block */
                } else { #if there is not block
                        $parent_name=join(".",@block_names);
                        $parent_name =~ s/^\.//; #hack
                        $blocks{$parent_name}.=$Template::Qtpl::block_start_delim . $v;
		}                                                              		}
	}
	return \%blocks;
}



#/***[ error stuff ]*********************************************************/
#/*
#	sets and gets error
#*/
sub get_error	{
	my $self = shift;
	return ($self->{ERROR} eq '') ? 0 : $self->{ERROR};
}


sub set_error {
	my $self = shift;
	my $str = shift;
	$self->{ERROR}=$str;
	die "$self->{ERROR}\n";
}

#/***[ getfile ]*************************************************************/
#/*	returns the contents of a file
sub getfile {
	my $self = shift;
	my $file = shift;
	if (!length($file)) {
		$self->set_error("Empty file name!");
		return '';
	}
#find path of original template
	if (($self->{FILENAME} ne $file) && dirname($self->{FILENAME})){
		$file = dirname($self->{FILENAME}) . '/' .$file;
	}
	unless (open(XTPLFILE, $file)){
		$self->set_error("Cannot open file: $file or file not exists");
		return '';
	}
	my @file_text = ;
	close(XTPLFILE);
	return join('',@file_text);
}

#/***[ r_getfile ]***********************************************************/
#/*
#	recursively gets the content of a file with {FILE "filename.tpl"} directives
#*/
sub r_getfile($file) {
	my $self = shift;
	my $file = shift;
	my $text=$self->getfile($file);
	while ($text =~ /(\{FILE\s*")(.+?)(\"\s*\})/g){
		my $full = $1.$2.$3;
		my $text2=$self->getfile($2);
		$text =~ s/$full/$text2/gi;
	}
	return $text;
}

1;

__END__