+# -*- cperl -*-
+# -----------------------------------------------------------------------------
+package POE::Component::IRC::Plugin::NoPaste::Template;
+use strict;
+use warnings;
+use Carp;
+use UNIVERSAL;
+our $AUTOLOAD;
+our $VERSION = 2;
+
+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 ###
+
+ <html>
+ <head>
+ <title>Sample Page - <t-tag:embed> - Sample Page</title>
+ </head>
+ <body>
+ <p>
+ <t-block:block>
+ line: <t-tag:foo><br>
+ </t-block:block>
+ </p>
+ </body>
+ </html>
+
+
+ ### 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 ###
+
+ <html>
+ <head>
+ <title>Sample Page - EMBED TITLE - Sample Page</title>
+ </head>
+ <body>
+ <p>
+
+ line: 1<br>
+
+ line: 2<br>
+
+ line: 3<br>
+
+ </p>
+ </body>
+ </html>
+
+=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 <!begin>, <!end> or not
+
+=item -lang => language to output
+
+Any blocks surrounded by <t-lang:...> and </t-lang:...> are treated as
+language specific block.
+
+ e.g.
+
+ <t-lang:default> This is default </t-lang:default>
+ <t-lang:ja> Nihongo(Japanese) </t-lang:ja>
+
+ 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 => <!begin>や<!end>の直後の改行を削除するかどうか,
+ # -lang => 言語名,
+ # )
+ my ($class, %args) = @_;
+ my $this = {
+ original => undef, # リーフを<!mark:foo>に置換した中身。
+ 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";
+ }
+
+ # <t-block:*>や<t-lang:*>の直後が改行コードなら、それを消す。
+ # その改行コードから始まるスペースまたはタブも、インデントと見做して消す。
+ if ($args{-strip}) {
+ $source =~ s{(</?t-block:.+?>|</?t-lang:.+?>)\x0d?\x0a[ \t]*}{$1}g;
+ }
+
+ # 言語
+ my $lang = 'default';
+ if ($args{-lang} and $source =~ m/<t-lang:\Q$args{-lang}\E>/) {
+ $lang = $args{-lang};
+ }
+ $source =~ s{<t-lang:(.+?)>(.+?)</t-lang:\1>}{
+ 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 => '+++');
+
+ # このメソッドは、キー内に現われたアンダースコアを
+ # ハイフンにフォールバックする事が出來る。
+ # つまり、<t-tag: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 ($this->{current} !~ s|<t-tag:\Q$key\E(?:\s*/)?>|$value|g) {
+ # 無い。アンダースコアをハイフンに変えてみる。
+ (my $tred_key = $key) =~ tr/_/-/;
+ if ($this->{current} !~ s|<t-tag:\Q$tred_key\E(?:\s*/)?>|$value|g) {
+ # そのようなキーは存在しなかった。警告。
+ #carp "No <t-tag:$key> 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.";
+ }
+
+ # 親の<t-mark:foo>の直前に、このリーフを挿入。
+ my $str = $this->str;
+ $this->{parent}{current} =~ s|(<t-mark:\Q$this->{leafname}\E(?:\s*/)?>)|$str$1|g;
+
+ # リセット
+ $this->reset;
+
+ $this;
+}
+
+sub str {
+ my $this = shift;
+ my $result = $this->{current};
+
+ # 未置換の<t-tag:foo>があればそれを消してcarp。
+ while ($result =~ s/(<t-tag:.+?>)//) {
+ carp "Unexpanded tag: $1";
+ }
+
+ # <t-mark:foo>を消す。
+ $result =~ s/<t-mark:.+?>//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) = @_;
+
+ # <t-block:foo> ... </t-block:foo>を<t-mark:foo>に置換しつつ、そのリーフを保存。
+ while ($source =~ s|<t-block:(.+?)>(.+?)</t-block:\1>|<t-mark:$1>|s) {
+ my ($leafname,$source) = ($1,$2);
+
+ if (defined $this->{leaves}{$leafname}) {
+ # 既にこのリーフが定義されていたらcroak。
+ croak "duplicated leaves in template: $leafname";
+ }
+ else {
+ $this->{leaves}{$leafname} = __PACKAGE__->_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;
+ $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;
+ $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 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|^</textarea>|i) {
+ next;
+ }
+ }
+
+ my $taghtml = $_;
+ if (!/^</) {
+ $outhtml .= $_;
+ 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 = '';
+ }
+
+ 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 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 (!/^</) {
+ $outhtml .= $_;
+ next;
+ }
+
+ my $tag = html2tag($taghtml);
+
+ if (defined $tag->{__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{<input type="hidden" name="%s" value="%s" />} :
+ q{<input type="hidden" name="%s" value="%s">};
+ $outhtml .= sprintf($format, $key, $uri->query_param($key));
+ }
+ }
+ }
+ }
+
+ $this->{current} = $outhtml;
+}
+
+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 (!/^</) {
+ $outhtml .= $_;
+ next;
+ }
+
+ if (defined $in_textarea) {
+ if (!m|^</textarea>|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;