# -*- 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;