ktemplate.pm

Astercon2 开源软交换 2.2.0

#=======================================================================
#
#   Copyright (c) 2002-2003 Kasper Dziurdz. All rights reserved.
#
#   This module is free software; you can redistribute it and/or
#   modify it under the same terms as Perl itself.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
#   Artistic License for more details.
#
#   Please email me any comments, questions, suggestions or bug 
#   reports to: <[e-mail]>
#
#=======================================================================

package HTML::KTemplate;
use strict;
use Carp;
use File::Spec;

use vars qw(
	$VAR_START_TAG $VAR_END_TAG 
	$BLOCK_START_TAG $BLOCK_END_TAG
	$INCLUDE_START_TAG $INCLUDE_END_TAG
	$ROOT $CHOMP $VERSION $CACHE
	$FIRST $INNER $LAST
);

$VERSION = '1.33';

$VAR_START_TAG = '[%';
$VAR_END_TAG   = '%]';

$BLOCK_START_TAG = '<!--';
$BLOCK_END_TAG   = '-->';

$INCLUDE_START_TAG = '<!--';
$INCLUDE_END_TAG   = '-->';

$ROOT  = undef;
$CHOMP = 1;
$CACHE = {};

$FIRST = { 'FIRST' => 1, 'first' => 1 };
$INNER = { 'INNER' => 1, 'inner' => 1 };
$LAST  = { 'LAST'  => 1, 'last'  => 1 };


sub TEXT   () { 0 }
sub VAR    () { 1 }
sub BLOCK  () { 2 }
sub FILE   () { 3 }
sub IF     () { 4 }
sub ELSE   () { 5 }
sub UNLESS () { 6 }
sub LOOP   () { 7 }

sub TYPE   () { 0 }
sub IDENT  () { 1 }
sub STACK  () { 2 }

sub NAME   () { 0 }
sub PATH   () { 1 }


sub new {

	my $class = shift;
	my $self = {
		'vars'   => [{}],  # values for template vars
		'loop'   => [],    # loop context variables
		'block'  => undef, # current block reference
		'files'  => [],    # file paths for include
		'output' => '',    # template output
		'config' => {      # configuration
			'cache'        => 0,
			'strict'       => 0,
			'no_includes'  => 0,
			'max_includes' => 15,
			'loop_vars'    => 0,
			'blind_cache'  => 0,
			'include_vars' => 0,
			'parse_vars'   => 0,
		},
	};

	$self->{'config'}->{'root'} = shift if @_ == 1;
	croak('Odd number of option parameters') if @_ % 2 != 0;

	# load in all option parameters
	$self->{'config'}->{$_} = shift while $_ = lc shift;

	$self->{'config'}->{'root'} = $ROOT
		unless exists $self->{'config'}->{'root'};

	$self->{'config'}->{'cache'} = 1
		if $self->{'config'}->{'blind_cache'};

	bless ($self, $class);
	return $self;

}


sub assign {

	my $self = shift;
	my ($target, $block);

	# odd number of arguments: block
	if (@_ % 2 != 0 && @_ >= 3) {
		$self->block(shift);
		++$block; 
	}
	
	# if a block reference is defined,
	# assign the variables to the block
	$target = defined $self->{'block'}
		? $self->{'block'}->[ $#{ $self->{'block'} } ]
		: $self->{'vars'}->[0];

	if (ref $_[0] eq 'HASH') {
		# copy data for faster variable lookup
		@{ $target }{ keys %{$_[0]} } = values %{$_[0]};
	} else {
		my %assign = @_;
		@{ $target }{ keys %assign } = values %assign;
	}
	
	# remove block reference
	$self->block() if $block;

	return 1;

} 


sub block {
# - creates a new loop in the defined block
# - sets a reference so all future variable values will
#   be assigned there (until this method is called again)

	my $self = shift;
	my (@ident, $root, $key, $last_key);
	
	# no argument: undefine block reference 
	if (!defined $_[0] || !length $_[0]) {
		$self->{'block'} = undef; 
		return 1;
	}
	
	push @ident, split /\./, shift while @_;
	$last_key = pop @ident;
	
	$root = $self->{'vars'}->[0];
	
	foreach $key (@ident) {
	
		# hash reference: perfect!
		if (ref $root->{$key} eq 'HASH') {
		$root = $root->{$key};
		}
	
		# array reference: block continues in hash 
		# reference at the end of the array
		elsif (ref $root->{$key} eq 'ARRAY' 
		  && ref $root->{$key}->[ $#{ $root->{$key} } ] eq 'HASH' ) {
		$root =  $root->{$key}->[ $#{ $root->{$key} } ];
		}
		
		else { # create new hash reference
		$root = $root->{$key} = {};
		}
		
	}
	
	if (ref $root->{$last_key} eq 'ARRAY') {
		# block exists: add new loop
		push @{ $root->{$last_key} }, {};
	} else {
		# create new block
		$root->{$last_key} = [{}];
	}
	
	$self->{'block'} = $root->{$last_key};
	
	return 1;
	
}


sub process {

	my $self = shift;

	foreach (@_) {
		next unless defined;
		$self->_include($_);
	}

	return 1;
	
}


sub _include {

	my $self = shift;
	my $filename = shift;
	my ($stack, $filepath);
	
	# check whether includes are disabled
	if ($self->{'config'}->{'no_includes'} && scalar @{ $self->{'files'} } != 0) {
		croak('Include blocks are disabled at ' . $self->{'files'}->[0]->[NAME])
			if $self->{'config'}->{'strict'};
		return; # no strict
	}
	
	# check for recursive includes
	croak('Recursive includes: maximum recursion depth of ' . $self->{'config'}->{'max_includes'} . ' files exceeded')
		if scalar @{ $self->{'files'} } > $self->{'config'}->{'max_includes'}; 

	($stack, $filepath) = $self->_load($filename);
	
	# add file path to use as include path
	unshift @{ $self->{'files'} }, [ $filename, $filepath ]
		if defined $filepath;
	
	# create output
	$self->_output($stack);
	
	# delete file info if it was added
	shift @{ $self->{'files'} }	if defined $filepath;

}


sub _load {
# - loads the template file from cache or hard drive
# - returns the parsed stack and the full template path

	my $self = shift;
	my $filename = shift;
	my ($filepath, $mtime, $filedata);
	
	# slurp the file
	local $/ = undef;
	
	# when the passed argument is a reference to a scalar,
	# array or file handle, load and use it as template

	if (ref $filename eq 'SCALAR') {
		# skip undef and do not change passed scalar
		$filedata = defined $$filename ? $$filename : '';
		return $self->_parse(\$filedata, '[scalar_ref]');
	}

	if (ref $filename eq 'ARRAY') {
		$filedata = join("", @$filename);
		return $self->_parse(\$filedata, '[array_ref]');
	}

	if (ref $filename eq 'GLOB') {
		$filedata = readline($$filename);
		$filedata = '' unless defined $filedata; # skip undef
		return $self->_parse(\$filedata, '[file_handle]');
	}

	# file handle (no reference)
	if (ref \$filename eq 'GLOB') {
		$filedata = readline($filename);
		$filedata = '' unless defined $filedata; # skip undef
		return $self->_parse(\$filedata, '[file_handle]');
	}

	($filepath, $mtime) = $self->_find($filename);
	
	croak("Can't open file $filename: file not found") 
		unless defined $filepath;
	
	if ($self->{'config'}->{'cache'}) {
		# load parsed template from cache
		$filedata = $CACHE->{$filepath};
		
		return ($filedata->[0], $filepath)
			if $self->{'config'}->{'blind_cache'} && defined $filedata;
		return ($filedata->[0], $filepath) 
			if defined $filedata && $filedata->[1] == $mtime;
	}
	
	open (TEMPLATE, '<' . $filepath) ||
		croak("Can't open file $filename: $!");
	$filedata = <TEMPLATE>;
	close TEMPLATE;
	
	$filedata = $self->_parse(\$filedata, $filename);
	
	# commit to cache
	$CACHE->{$filepath} = [ $filedata, $mtime ]
		if $self->{'config'}->{'cache'};

	return ($filedata, $filepath);

}


sub _find {
# - searches for the template file in the 
#   root path or from where it was included
# - returns a full path and the mtime or 
#   undef if the file cannot be found

    my $self = shift;
    my $filename = shift;
    my ($inclpath, $filepath);

    $filepath = defined $self->{'config'}->{'root'}
        ? File::Spec->catfile($self->{'config'}->{'root'}, $filename)
        : File::Spec->canonpath($filename);

	return $filepath if $self->{'config'}->{'blind_cache'}
		&& defined $CACHE->{$filepath};
	return ($filepath, (stat(_))[9]) if -e $filepath;

	# check path from where the file was included
    if (defined $self->{'files'}->[0]->[PATH]) {
		$inclpath = $self->{'files'}->[0]->[PATH];
        $inclpath = [ File::Spec->splitdir($inclpath) ];
        $inclpath->[$#$inclpath] = $filename;
        $filepath = File::Spec->catfile(@$inclpath);
		$filepath = File::Spec->canonpath($filepath);
		
		return $filepath if $self->{'config'}->{'blind_cache'}
			&& defined $CACHE->{$filepath};
		return ($filepath, (stat(_))[9]) if -e $filepath;
		
		# check path from variable
		if ($self->{'config'}->{'include_vars'}) {
			$filepath = File::Spec->canonpath( $self->_get($filename) );
			return $filepath if $self->{'config'}->{'blind_cache'}
				&& defined $CACHE->{$filepath};
			return ($filepath, (stat(_))[9]) if -e $filepath;
		}
		
    }
	
    return undef;
	
}


sub _parse {
# - parses the template data passed as a reference 
# - returns the finished stack

	my $self = shift;
	my $filedata = shift;
	my $filename = shift;
	my ($text, $tag, $type, $ident);
	my ($regexp, $line, $block, $space);
	my (@idents, @pstacks);

	$line = 1; # current line
	@pstacks = ([]);
	
	# block and include tags are the same by default.
	# if that wasn't changed, use a faster regexp.
	
	$regexp = $BLOCK_START_TAG eq $INCLUDE_START_TAG 
		&& $BLOCK_END_TAG eq $INCLUDE_END_TAG
		
		? qr/^
			(.*?)
			(
				\Q$VAR_START_TAG\E		
				\s*
				([\w.-]+)
				\s*			
				\Q$VAR_END_TAG\E
			|
				\Q$BLOCK_START_TAG\E		
				\s*
				(?:
					(
						[Bb][Ee][Gg][Ii][Nn]
						|
						[Ee][Nn][Dd]
						|
						[Ii][Ff]
						|
						[Ll][Oo][Oo][Pp]
						|
						[Ee][Ll][Ss][Ee]
						|
						[Uu][Nn][Ll][Ee][Ss][Ss]
					) 
					(?: \s+ ([\w.-]+) )?
				|
					([Ii][Nn][Cc][Ll][Uu][Dd][Ee])\s+
					(?: "([^"]*?)" | '([^']*?)' | (\S*?) )
				)
				\s*
				\Q$BLOCK_END_TAG\E
			)
			/sx
			
		: qr/^
			(.*?)
			(
				\Q$VAR_START_TAG\E		
				\s*
				([\w.-]+)
				\s*			
				\Q$VAR_END_TAG\E
			|
				\Q$BLOCK_START_TAG\E		
				\s*
				(
					[Bb][Ee][Gg][Ii][Nn]
					|
					[Ee][Nn][Dd]
					|
					[Ii][Ff]
					|
					[Ll][Oo][Oo][Pp]
					|
					[Ee][Ll][Ss][Ee]
					|
					[Uu][Nn][Ll][Ee][Ss][Ss]
				)
				(?: \s+ ([\w.-]+) )?
				\s*
				\Q$BLOCK_END_TAG\E
			|
				\Q$INCLUDE_START_TAG\E		
				\s*
				([Ii][Nn][Cc][Ll][Uu][Dd][Ee])\s+
				(?: "([^"]*?)" | '([^']*?)' | (\S*?) )
				\s*
				\Q$INCLUDE_END_TAG\E
			)
			/sx;
			
	while ($$filedata =~ s/$regexp//sx) {

		$text  = $1;  # preceding text
		$tag   = $2;  # whole tag (needed for line count)
		$type  = $4 || $6;  # tag type (undef for var)
		$ident = defined $3 ? $3 : defined $5 ? $5 : defined $7 ? $7 : 
				 defined $8 ? $8 : defined $9 ? $9 : undef;
	
		# get line position