# -*- cperl -*-
package Template;
use strict;
use warnings;
use Carp;
use UNIVERSAL;
our $AUTOLOAD;
our $VERSION = 4;
our $SETFORM_SUPPORTED = 1;
BEGIN {
eval q{ use URI; use URI::QueryParam; };
$@ and $SETFORM_SUPPORTED = 0;
}
=head1 NAME
Template - Text Template Class (especially for (x)html)
=head1 SYNOPSIS
### sample.html ###
Sample Page - <t-tag:embed> - Sample Page
line:
### sample.pl ###
use Template;
my $t = Template->new(
-fpath => './sample.html',
);
$t->expand(
embed => 'EMBED TITLE',
);
foreach (1 .. 3) {
$t->block->add(
foo => ".: $_ :.",
);
}
print $t->str;
### output ###
Sample Page - EMBED TITLE - Sample Page
line: 1
line: 2
line: 3
=head1 DESCRIPTION
not available yet...
=head1 CONSTRUCTOR
=over 4
=item $t = Template->new( %args );
=over 8
=item -fpath => file to use as template (one of this and -data is required)
=item -data => data to use as template
=item -strip => whether delete newlines after , or not
=item -lang => language to output
Any blocks surrounded by and are treated as
language specific block.
e.g.
This is default
Nihongo(Japanese)
my $t = Template->new(
-fpath => './foo.html',
-lang => 'ja');
print $t->str; # this shows "Nihongo(Japanese)"
$t = Template->new(
-fpath => './foo.html',
-lang => 'en');
print $t->str; # this shows "This is default"
=back
=back
=cut
sub new {
# %args = (
# -fpath => テンプレートとして使用するファイル
# -data => テンプレートとして使用するデータ
# -strip => やの直後の改行を削除するかどうか,
# -lang => 言語名,
# )
my ($class, %args) = @_;
my $this = {
original => undef, # リーフをに置換した中身。
current => undef, # <&foo>を置換した後のもの。
leaves => {}, # {名前 => Template}
parent => undef, # これがトップレベルでなければ、親(Template)。
leafname => undef, # これがトップレベルでなければ、リーフ名。
};
bless $this => $class;
my $source;
if (defined $args{-fpath}) {
if (defined $args{-data}) {
croak "You can't specify both of -fpath and -data at the same time.\n";
}
local $/ = undef;
open my $fh, '<', $args{-fpath}
or croak "Failed to open file $args{-fpath}";
$source = <$fh>;
close($fh);
}
elsif (defined $args{-data}) {
$source = $args{-data};
}
else {
croak "Missing both of -fpath and -data. Read `perldoc Template'\n";
}
# やの直後が改行コードなら、それを消す。
# その改行コードから始まるスペースまたはタブも、インデントと見做して消す。
if ($args{-strip}) {
$source =~ s{(|)\x0d?\x0a[ \t]*}{$1}g;
}
# 言語
my $lang = 'default';
if ($args{-lang} and $source =~ m//) {
$lang = $args{-lang};
}
$source =~ s{(.+?)}{
if ($1 eq $lang) {
$2;
}
else {
'';
}
}seg;
$this->_load($source);
$this;
}
sub reset {
my $this = shift;
$this->{current} = $this->{original};
$this;
}
sub expand {
# $t->expand({foo => '---' , bar => '+++'});
# もしくは
# $t->expand(foo => '---' , bar => '+++');
# このメソッドは、キー内に現われたアンダースコアを
# ハイフンにフォールバックする事が出來る。
# つまり、というタグを、キー名"foo_bar"で指定する事が出來る。
my $this = shift;
my $hash = do {
if (@_ == 1 && UNIVERSAL::isa($_[0],'HASH')) {
$_[0];
}
elsif (@_ % 2 == 0) {
my %h = @_;
\%h;
}
else {
croak "Illegal argument for Template->expand";
}
};
while (my ($key,$value) = each %$hash) {
# $key,$value共にスカラー値でなければならない。
# リファならエラー。
if (!defined $value) {
croak "Values must not be undef; key: $key";
}
if (ref($key) ne '') {
croak "Keys and values must be scalar values: $key";
}
if (ref($value) ne '') {
croak "Keys and values must be scalar values: $value";
}
if ($key =~ s/^raw://) {
# valueを弄らない
}
else {
$value = escape_tag($value);
}
if ($this->{current} !~ s||$value|g) {
# 無い。アンダースコアをハイフンに変えてみる。
(my $tred_key = $key) =~ tr/_/-/;
if ($this->{current} !~ s||$value|g) {
# そのようなキーは存在しなかった。警告。
#carp "No are in template, or you have replaced it already";
}
}
}
$this;
}
sub add {
my $this = shift;
# 引数があればexpandする。
if (@_ > 0) {
eval {
$this->expand(@_);
}; if ($@) {
croak $@;
}
}
# 親が存在しなければcroak。
if (!defined $this->{parent}) {
croak "This template doesn't have its parent.";
}
# 親のの直前に、このリーフを挿入。
my $str = $this->str;
$this->{parent}{current} =~ s|({leafname}\E(?:\s*/)?>)|$str$1|g;
# リセット
$this->reset;
$this;
}
sub str {
my $this = shift;
my $result = $this->{current};
# 未置換のがあればそれを消してcarp。
while ($result =~ s/()//) {
carp "Unexpanded tag: $1";
}
# を消す。
$result =~ s///g;
$result;
}
sub leaf {
my ($this,$leafname) = @_;
$this->{leaves}{$leafname};
}
sub AUTOLOAD {
my $this = shift;
(my $leafname = $AUTOLOAD) =~ s/.+?:://g;
# 余分な引數が付いてゐれば、恐らくこれは關數名の誤り。
if (@_) {
croak "Calling autoloaded Template->$leafname with extra arguments must be a mistake";
}
# アンダースコアはハイフンに置換。
$leafname =~ tr/_/-/;
$this->{leaves}{$leafname};
}
sub _new_leaf {
my ($class,$parent,$leafname,$source) = @_;
my $this = {
original => undef,
current => undef,
leaves => {},
parent => $parent,
leafname => $leafname,
};
bless $this,$class;
$this->_load($source);
}
sub _load {
my ($this,$source) = @_;
# ... をに置換しつつ、そのリーフを保存。
while ($source =~ s|(.+?)||s) {
my ($leafname,$source) = ($1,$2);
if (defined $this->{leaves}{$leafname}) {
# 既にこのリーフが定義されていたらcroak。
croak "duplicated leaves in template: $leafname";
}
else {
$this->{leaves}{$leafname} = Template->_new_leaf($this,$leafname,$source);
}
}
$this->{original} = $this->{current} = $source;
$this;
}
sub escape_tag {
my @args = @_;
my @result;
foreach my $str (@args) {
if (defined $str) {
$str =~ s/\&/\&/g;
$str =~ s//\>/g;
$str =~ s/\"/\"/g;
}
push @result, $str;
}
wantarray ? @result : $result[0];
}
sub unescape_tag {
my @args = @_;
my @result;
foreach my $str (@args) {
if (defined $str) {
$str =~ s/\<//g;
$str =~ s/\"/\"/g;
$str =~ s/\&/\&/g;
}
push @result, $str;
}
wantarray ? @result : $result[0];
}
sub html2tag {
my $tag = {};
$_ = shift;
s|^<||;
s|^(/?\w+)|| and $tag->{__top} = lc $1;
while (1) {
s|([\w\-]+)=([\"\'])(.*?)\2|| and do {
$tag->{lc $1} = $3;
next;
};
s|([\w\-]+)=([^\s\>]+)|| and do {
$tag->{lc $1} = $2;
next;
};
s,(\w+|/),, and do {
$tag->{__end} = lc $1;
next;
};
last;
}
my $new = {};
foreach (keys %$tag) {
$new->{unescape_tag($_)} = unescape_tag($tag->{$_});
}
$new;
}
sub tag2html {
my $tag = shift;
my $html;
$html .= '<' . $tag->{__top};
foreach (keys %$tag) {
/^__/ and next;
$html .= sprintf ' %s="%s"', escape_tag($_), escape_tag($tag->{$_});
}
defined $tag->{__end} and
$html .= ' ' . $tag->{__end};
$html .= '>';
$html;
}
sub set_form {
goto &setform;
}
sub setform {
# $uri: URI
my ($this, $uri, $name) = @_;
defined $name or $name = '';
if (!UNIVERSAL::isa($uri, 'URI')) {
croak "Usage: Template->setform(URI [, name])";
}
$SETFORM_SUPPORTED or
croak "Install URI::QueryParam to enable setform";
my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
my $outhtml = '';
my $in_select; # name
my $in_select_option_tag; # tag
my $in_textarea; # name
my $in_form = ''; # name
foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
if (defined $in_select and defined $in_select_option_tag) {
my $value = '';
/^([^ \<\r\n]*)/i and $value = $1;
my $tag = $in_select_option_tag;
if (grep {$value eq $_} $uri->query_param($in_select)) {
$tag->{$is_xhtml ? 'selected' : '__end'} = 'selected';
}
else {
delete $tag->{$is_xhtml ? 'selected' : '__end'};
}
$outhtml .= tag2html($tag);
undef $in_select_option_tag;
}
if (defined $in_textarea) {
if (!m|^|i) {
next;
}
}
my $taghtml = $_;
if (!/^{__top}) {
$outhtml .= $taghtml;
}
elsif ($tag->{__top} eq 'form') {
if (defined($_ = $tag->{name})) {
$in_form = unescape_tag($_);
}
else {
$in_form = '';
}
if (!$tag->{action}) {
my $act = $uri->clone;
$act->query(undef);
$act->fragment(undef);
$tag->{action} = $act->canonical->as_string;
}
$outhtml .= tag2html($tag);
}
elsif ($name ne $in_form) {
$outhtml .= $taghtml;
}
elsif ($tag->{__top} eq 'input') {
if (defined $tag->{name}) {
my $type = $tag->{type};
if (!$type or
grep {$_ eq $type} qw[text password hidden submit]) {
if (defined(my $value = $uri->query_param($tag->{name}))) {
$tag->{value} = $value;
}
$outhtml .= tag2html($tag);
}
elsif (grep {$_ eq $type} qw[radio checkbox]) {
if (defined $tag->{value} and
grep {$_ eq $tag->{value}}
$uri->query_param($tag->{name})) {
$tag->{$is_xhtml ? 'checked' : '__end'} = 'checked';
}
else {
delete $tag->{$is_xhtml ? 'checked' : '__end'};
}
$outhtml .= tag2html($tag);
}
else {
$outhtml .= $taghtml;
}
}
else {
$outhtml .= $taghtml;
}
}
elsif ($tag->{__top} eq 'textarea') {
if (defined($_ = $tag->{name})) {
$in_textarea = $_;
$outhtml .= tag2html($tag);
if (defined(my $value = $uri->query_param($_))) {
$outhtml .= escape_tag($value);
}
}
else {
$outhtml .= tag2html($tag);
}
}
elsif ($tag->{__top} eq '/textarea') {
$outhtml .= tag2html($tag);
undef $in_textarea;
}
elsif ($tag->{__top} eq 'select') {
if (defined($_ = $tag->{name})) {
$in_select = $_;
}
$outhtml .= tag2html($tag);
}
elsif ($tag->{__top} eq '/select') {
$outhtml .= tag2html($tag);
undef $in_select;
}
elsif (defined $in_select) {
if ($tag->{__top} eq 'option') {
if (defined(my $val = $tag->{value})) {
if (grep {$val eq $_} $uri->query_param($in_select)) {
$tag->{$is_xhtml ? 'selected' : '__end'} = 'selected';
}
else {
delete $tag->{$is_xhtml ? 'selected' : '__end'};
}
$outhtml .= tag2html($tag);
}
else {
$in_select_option_tag = $tag;
}
}
else {
$outhtml .= $taghtml;
}
}
else {
$outhtml .= $taghtml;
}
}
$this->{current} = $outhtml;
}
sub add_hidden_form {
goto &addhiddenform;
}
sub addhiddenform {
# $uri: URI or HASH
my ($this, $uri, $name) = @_;
defined $name or $name = '';
$SETFORM_SUPPORTED or
croak "Install URI::QueryParam to enable setform";
if (!UNIVERSAL::isa($uri, 'URI')) {
if (UNIVERSAL::isa($uri, 'HASH')) {
my $u = URI->new('', 'http');
while (my ($key, $value) = each %$uri) {
$u->query_param(
$key => UNIVERSAL::isa($value, 'ARRAY') ? @$value : $value);
}
$uri = $u;
}
else {
croak "\$uri was not URI nor HASH";
}
}
my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
my $outhtml = '';
foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
my $taghtml = $_;
if (!/^{__top} and
$tag->{__top} eq 'form' and
!$tag->{action}) {
my $act = $uri->clone;
$act->query(undef);
$act->fragment(undef);
$tag->{action} = $act->canonical->as_string;
$outhtml .= tag2html($tag);
}
else {
$outhtml .= $taghtml;
}
if (defined $tag->{__top} and
$tag->{__top} eq 'form') {
if ((!defined $tag->{name} and $name eq '') or
(defined $tag->{name} and $name eq $tag->{name})) {
foreach my $key ($uri->query_param) {
my $format = $is_xhtml ?
q{} :
q{};
$outhtml .= sprintf($format, $key, $uri->query_param($key));
}
}
}
}
$this->{current} = $outhtml;
}
sub disable_form {
goto &disableform;
}
sub disableform {
my ($this, $keylist, $name) = @_;
defined $name or $name = '';
my %keyhash = map {$_ => 1} @$keylist;
my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
my $outhtml = '';
my $in_textarea; # name
my $in_form = '';
foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
my $taghtml = $_;
if (!/^|i) {
next;
}
}
my $tag = html2tag($taghtml);
if (!defined $tag->{__top}) {
$outhtml .= $taghtml;
}
elsif ($tag->{__top} eq 'form') {
if (defined($_ = $tag->{name})) {
$in_form = unescape_tag($_);
}
else {
$in_form = '';
}
$outhtml .= tag2html($tag);
}
elsif ($name ne $in_form) {
$outhtml .= $taghtml;
}
elsif ($tag->{__top} eq 'textarea') {
$in_textarea = 1;
$outhtml .= tag2html($tag);
}
elsif ($tag->{__top} eq '/textarea') {
$outhtml .= tag2html($tag);
undef $in_textarea;
}
elsif ($tag->{__top} eq 'input' or
$tag->{__top} eq 'select' or
$tag->{__top} eq 'textarea') {
my $name = $tag->{name};
if ($name and $keyhash{$name}) {
# disable this
$tag->{$is_xhtml ? 'disabled' : '__end'} = 'disabled';
# nameを消したいところだが、多分消した時の動作は實裝依存になる。
# 代はりにnameを別の名前に變換する。
$tag->{name} = sprintf 'DiSaBLeD_%s_DiSaBLeD', $tag->{name};
}
$outhtml .= tag2html($tag);
}
else {
$outhtml .= $taghtml;
}
}
$this->{current} = $outhtml;
}
1;