# ======================================================================
# TextTemplate.pm - テキストテンプレート
#
# Copyright (c) 2001 by DEVIL QCUMBER All Rights Reserverd.
# ----------------------------------------------------------------------

use strict;

package TextTemplate;

sub new
{
	my $type = shift;

	my $self = bless { }, $type;

	$self->{VAR} = TextTemplate::Variable->new();

	$self->_set_default();

	$self->set_option(@_);

	return $self;
}


sub _set_default
{
	my $self = shift;

	$self->set_option(
		TAG_PREFIX => "T_",
		ATTR_SEP   => ";",
		VAR_PREFIX => "{",
		VAR_SUFFIX => "}",
	);

	$self->set(
		""  => "",
		"(" => "{",
		")" => "}",
	);

	return $self;
}


sub set_option
{
	my $self = shift;
	my %hash = @_;

	while (my ($name, $val) = each %hash) {
		$self->{OPT}->{$name} = $val;
	}

	return $self;
}


sub set_template_file
{
	my $self = shift;
	my ($path,) = @_;

	$self->set_option(FILENAME => $path);
	$self->{TEMPLATE} = undef;

	return $self;
}


#
# テンプレート文字列
#
sub set_template
{
	my $self = shift;

	$self->{TEMPLATE} = join("", @_);
	$self->{TREE} = undef;

	return $self;
}


sub read_template_file
{
	my $self = shift;
	my ($path,) = @_;

	if ($path eq "") {
		die "no template";
	}

	open(FH, "<$path") or die "can't read template: $path";
	$self->set_template(join("", <FH>));
	close(FH);

	return $self;
}


#
# 変数のセット
#
sub set
{
	my $self = shift;

	$self->{VAR}->store(@_);

	return $self;
}

sub param { shift->set(@_) }


#
# フィルタ
#
sub set_filter
{
	my $self = shift;

	$self->{VAR}->set_filter(@_);

	return $self;
}


#
# 文字列展開
#
sub to_s
{
	my $self = shift;

	if (!$self->{TEMPLATE}) {
		$self->read_template_file($self->{OPT}->{FILENAME});
	}

	if (!$self->{TREE}) {
		my $compiler = TextTemplate::Parser->new(%{$self->{OPT}});
		$self->{TREE} = $compiler->parse($self->{TEMPLATE});
	}

	my $extractor = TextTemplate::Extractor->new(%{$self->{OPT}});

	return $extractor->extract($self->{TREE}, $self->{VAR});
}

sub output { shift->to_s() }


# ======================================================================
# コンパイラ
# ----------------------------------------------------------------------

package TextTemplate::Parser;

sub new
{
	my $type = shift;

	my $self = bless { @_ }, $type;

	return $self;
}


sub parse
{
	my $self = shift;
	my ($text,) = @_;

	my $tag_prefix = $self->{TAG_PREFIX};
	my $branch = TextTemplate::Parser::Tree->new();

	while ($text =~ /^(.*?)(<(\/?)$tag_prefix([^\/>\s]+)(.*?)(\/?)>)(.*)$/is) {
		#
		# テンプレート用タグがある間…
		#
		my $pre_text   = $1;                     # タグの前のテキスト
		my $tag        = $2;                     # タグ全体(エラーメッセージ用)
		my $closer_tag = $3 ne "";               # 閉じタグらしい
		my $name       = uc($4);                 # 要素名
		my $attr       = $self->parse_attr($5);  # 属性ハッシュ
		my $alone_tag  = $6 ne "";               # 独立タグらしい
		my $rest_text  = $7;                     # タグの後のテキスト

		if ($closer_tag && $alone_tag) {
			die "illegal tag: $tag";
		}

		#
		# タグに接する文字の処理
		#
		if ($closer_tag) {
			$pre_text =~ s/\s+$//s;
		}
		elsif (!$alone_tag) {
			$rest_text =~ s/^\s+//s;
		}

		#
		# タグの前にテキストがあれば無名要素に
		#
		if ($pre_text ne "") {
			$branch->add_text($pre_text);
		}

		if ($closer_tag) {
			if ($branch->is_root()) {
				die "BEGIN...$tag";
			}
			my $element = $branch->close();
			if ($name ne $element->{NAME}) {
				die "mismatch: $element->{TAG}...$tag";
			}
		}
		elsif ($alone_tag) {
			$branch->add($name, $tag, $attr);
		}
		else {
			$branch->open($name, $tag, $attr);
		}

		$text = $rest_text;
	}

	if ($text ne "") {
		$branch->add_text($text);
	}

	#
	# 整合チェック
	#
	if (!$branch->is_root()) {
		my $element = $branch->close();
		die "$element->{TAG}...END";
	}

	return $branch->close();
}


#
# 属性解析
#
sub parse_attr
{
	my $self = shift;
	my ($text,) = @_;

	my $attr = { };

	while ($text =~ /^\s*(\S+)\s*=\s*("[^"]*"|'[^']*'|\S+)(.*)$/) {
		my $name      = uc($1);
		my $value     = $2;
		my $rest_text = $3;

		#
		# 引用符をとる
		# %HH をデコード
		#
		$value =~ s/^(["'])(.*)\1$/$2/;
		$value =~ s/%([0-9A-F]{2})/chr hex $1/ig;

		$attr->{$name} = $value;

		$text = $rest_text;
	}

	return $attr;
}


# ======================================================================
# 構文木
# ----------------------------------------------------------------------

package TextTemplate::Parser::Tree;

sub new
{
	my $type = shift;

	my $self = bless { }, $type;

	$self->{STACK} = [ TextTemplate::Element->new("root") ];

	return $self;
}


sub is_root
{
	my $self = shift;

	return @{$self->{STACK}} == 1;
}


sub add
{
	my $self = shift;

	push @{$self->{STACK}->[0]->{CONTENT}}, TextTemplate::Element->new(@_);

	return $self;
}


sub add_text
{
	my $self = shift;

	push @{$self->{STACK}->[0]->{CONTENT}}, TextTemplate::Element->new("text", "", { }, @_);

	return $self;
}


sub open
{
	my $self = shift;

	my $element = TextTemplate::Element->new(@_);

	push @{$self->{STACK}->[0]->{CONTENT}}, $element;
	unshift @{$self->{STACK}}, $element;

	return $self;
}


sub close
{
	my $self = shift;

	return shift @{$self->{STACK}};
}


# ======================================================================
# 構文要素
# ----------------------------------------------------------------------

package TextTemplate::Element;

sub new
{
	my $type = shift;
	my ($name, $tag, $attr, $content) = @_;

	my $self = bless { }, $type;

	$self->{NAME}    = $name;
	$self->{TAG}     = $tag;
	$self->{ATTR}    = $attr    || { };
	$self->{CONTENT} = $content || [ ];

	return $self;
}


#
# アクセス
#
sub name { shift->{NAME} }
sub attr { shift->{ATTR} }
sub content { wantarray ? @{shift->{CONTENT}} : shift->{CONTENT} }


# ======================================================================
# 変数
# ----------------------------------------------------------------------

package TextTemplate::Variable;

sub new
{
	my $type = shift;

	my $self = bless { }, $type;

	$self->{STACK} = [ ];
	$self->begin_scope(@_);

	$self->_set_default();

	return $self;
}


sub _set_default
{
	my $self = shift;
	
	$self->set_filter(
		HTML => \&f_HTML,
		URI  => \&f_URI,
		URL  => \&f_URI,
		BR   => \&f_BR,
		CR   => \&f_CR,
	)

}


#
# 現在のスコープから外側に向かって
# 変数nameを探し、値を得る。
# みつからないときはundef。
#
sub fetch
{
	my $self = shift;
	my ($name,) = @_;

	foreach my $v (@{$self->{STACK}}) {
		if (exists $v->{$name}) {
			return $v->{$name};
		}
	}
	return undef;
}


#
# 現在のスコープで変数を定義
#
sub store
{
	my $self = shift;
	my %hash = @_;

	while (my ($name, $val) = each %hash) {
		$self->{STACK}->[0]->{$name} = $val;
	}

	return $self;
}


#
# 新しいスコープを作る
#
sub begin_scope
{
	my $self = shift;
	my %hash = @_;

	unshift @{$self->{STACK}}, \%hash;

	return $self;
}


#
# 現在のスコープを抜けて外側へ
#
sub end_scope
{
	my $self = shift;

	shift @{$self->{STACK}};

	return $self;
}


#
# フィルタ指定による変換
#
sub set_filter
{
	my $self = shift;
	my %hash = @_;

	while (my ($name, $func) = each %hash) {
		$self->{FILTER}->{$name} = $func;
	}

	return $self;
}


sub get_val
{
	my $self = shift;
	my ($name,) = @_;

	my ($vname, $f, $fname) = $name =~ /([^:]*)(:(\S*))?/;
	my $val = $self->fetch($vname);

	if ($f eq "" || !defined $val) {
		return $val;
	}

	if (!exists $self->{FILTER}->{$fname}) {
		die "unknown filter \"$fname\"";
	}
	my $func = $self->{FILTER}->{$fname};

	return &$func($val);
}


#
# デフォルトフィルタ
#
sub f_HTML
{
	local $_ = $_[0];
	s/\&/\&amp;/g;
	s/\"/\&quot;/g;
	s/\</\&lt;/g;
	s/\>/\&gt;/g;
	$_
}

sub f_URI
{
	local $_ = $_[0];
	s/([^-A-Za-z0-9_.!~\*'()])/sprintf("%%%02X", ord $1)/eg;
	$_
}

sub f_BR
{
	local $_ = $_[0];
	s/\r\n|\n|\r/<br>/g;
	$_
}

sub f_CR
{
	local $_ = $_[0];
	s/<br>/\n/ig;
	$_
}



# ======================================================================
# 展開くん
# ----------------------------------------------------------------------

package TextTemplate::Extractor;

sub new
{
	my $type = shift;

	my $self = bless { @_ }, $type;

	return $self;
}


#
# 要素のコンテンツを展開
#
sub extract
{
	my $self = shift;
	my ($elem, $var) = @_;

	my $text;
	foreach my $e ($elem->content) {
		$text .= $self->dispatch($e, $var);
	}

	return $text;
}


#
# 要素名に応じたファンクションを呼び出す
#
sub dispatch
{
	my $self = shift;
	my ($elem, $var) = @_;

	my $name = $elem->name;

	my $func = "do_$name";
	if (!$self->can($func)) {
		die "unknown function: \"$name\"";
	}

	return $self->$func($elem, $var);
}


#
# 真偽判定 (if系要素の下請け)
#
sub cond
{
	my $self = shift;
	my ($elem, $var, $comp_val) = @_;

	my $attr = $elem->attr;

	if (exists $attr->{NAME}) {
		$attr->{NAME} =~ /(!?)(.*)$/;
		my $yes = $1 eq "";
		my $val = $var->fetch($2);

		if (exists $attr->{VALUE}) {
			return $val eq $attr->{VALUE} ? $yes : !$yes;
		}

		if (defined $comp_val) {
			return $val eq $comp_val ? $yes : !$yes;
		}

		if (ref $val eq "ARRAY") {
			return (scalar(@$val) >=0 )? $yes : !$yes;
		}

		return $val ? $yes : !$yes;
	}

	if (exists $attr->{VALUE}) {
		my $value = $attr->{VALUE};

		if (defined $comp_val) {
			return $value eq $comp_val;
		}

		return $value;
	}

	return 1;
}


# =======================================
# ファンクション
# ---------------------------------------

#
# テキスト(必須)
#

sub do_text
{
	my $self = shift;
	my ($elem, $var) = @_;

	if (!$self->{VAR_PREFIX} || !$self->{VAR_SUFFIX}) {
		return $elem->content;
	}

	my $content = $elem->content;
	$content =~ s/($self->{VAR_PREFIX}(\S*?)$self->{VAR_SUFFIX})/{
		my $val = $var->get_val($2);
		defined $val ? $val : ""  # $1
	}/eg;

	return $content;
}


#
# var name="var"
#
# varがあればそれで置き換え
# ないときはコンテンツを展開
#
sub do_VAR
{
	my $self = shift;
	my ($elem, $var) = @_;

	my $name = $elem->attr->{NAME};

	if (exists $elem->attr->{FILTER}) {
		$name .= ":" . $elem->attr->{FILTER};
	}

	return $var->get_val($name) || $self->extract($elem, $var);
}


#
# if [name="var"] [value="value"]
#
sub do_IF
{
	my $self = shift;
	my ($elem, $var) = @_;

	return $self->cond($elem, $var) ? $self->extract($elem, $var) : "";
}


#
# case [name="var"]
#
sub do_CASE
{
	my $self = shift;
	my ($elem, $var) = @_;

	my $comp_val;
	if (exists $elem->attr->{NAME}) {
		$comp_val = $var->fetch($elem->attr->{NAME}) . "";
	}
	foreach my $e ($elem->content) {
		if ($e->name eq "IF") {
			if ($self->cond($e, $var, $comp_val)) {
				return $self->extract($e, $var);
			}
		} else {
			$self->dispatch($e, $var);
		}
	}
	return "";
}


#
# for name="loop"
#
sub do_FOR
{
	my $self = shift;
	my ($elem, $var) = @_;

	my $text;
	my $list = $var->fetch($elem->attr->{NAME});
	if ($list) {
		foreach my $v (@{$list}) {
			$var->begin_scope(%$v);
			$text .= $self->extract($elem, $var);

			$var->end_scope();
		}
	}

	return $text;
}

sub do_LOOP { shift->do_FOR(@_) }

#
# include file="ya.tmpl" / name="template"
#
sub do_INCLUDE
{
	my $self = shift;
	my ($elem, $var) = @_;

	my $attr = $elem->attr;

	my $filename = $var->fetch($attr->{NAME}) || $attr->{FILE};
	open(FH, $filename) or return $self->extract($elem, $var);
	my $template = join("", <FH>);
	close(FH);

	my $tree = TextTemplate::Parser->new(%$self)->parse($template);
	return TextTemplate::Extractor->new(%$self)->extract($tree, $var);
}


1;

__END__

# ======================================================================
# 2001/08/13  1.00   pen@super.win.ne.jp
# - create
# ----------------------------------------------------------------------
# TextTemplate.pm
