lib/POE/Component/IRC/Plugin/NoPaste/Template.pm

   1 # -*- cperl -*-
   2 # -----------------------------------------------------------------------------
   3 package POE::Component::IRC::Plugin::NoPaste::Template;
   4 use strict;
   5 use warnings;
   6 use Carp;
   7 use UNIVERSAL;
   8 our $AUTOLOAD;
   9 our $VERSION = 2;
  10
  11 our $SETFORM_SUPPORTED = 1;
  12 BEGIN {
  13     eval q{ use URI; use URI::QueryParam; };
  14     $@ and $SETFORM_SUPPORTED = 0;
  15 }
  16
  17 =head1 NAME
  18
  19     Template - Text Template Class (especially for (x)html)
  20
  21 =head1 SYNOPSIS
  22
  23     ### sample.html ###
  24
  25     <html>
  26       <head>
  27         <title>Sample Page - <t-tag:embed> - Sample Page</title>
  28       </head>
  29       <body>
  30         <p>
  31           <t-block:block>
  32             line: <t-tag:foo><br>
  33           </t-block:block>
  34         </p>
  35       </body>
  36     </html>
  37
  38
  39     ### sample.pl ###
  40
  41     use Template;
  42     my $t = Template->new(
  43         -fpath => './sample.html',
  44     );
  45     $t->expand(
  46         embed => 'EMBED TITLE',
  47     );
  48     foreach (1 .. 3) {
  49         $t->block->add(
  50             foo => ".: $_ :.",
  51         );
  52     }
  53     print $t->str;
  54
  55
  56     ### output ###
  57
  58     <html>
  59       <head>
  60         <title>Sample Page - EMBED TITLE - Sample Page</title>
  61       </head>
  62       <body>
  63         <p>
  64
  65           line: 1<br>
  66
  67           line: 2<br>
  68
  69           line: 3<br>
  70
  71         </p>
  72       </body>
  73     </html>
  74
  75 =head1 DESCRIPTION
  76
  77 not available yet...
  78
  79 =head1 CONSTRUCTOR
  80
  81 =over 4
  82
  83 =item $t = Template->new( %args );
  84
  85 =over 8
  86
  87 =item -fpath => file to use as template (one of this and -data is required)
  88
  89 =item -data => data to use as template
  90
  91 =item -strip => whether delete newlines after <!begin>, <!end> or not
  92
  93 =item -lang => language to output
  94
  95 Any blocks surrounded by <t-lang:...> and </t-lang:...> are treated as
  96 language specific block.
  97
  98     e.g.
  99
 100     <t-lang:default> This is default </t-lang:default>
 101     <t-lang:ja> Nihongo(Japanese) </t-lang:ja>
 102
 103     my $t = Template->new(
 104         -fpath => './foo.html',
 105         -lang  => 'ja');
 106     print $t->str; # this shows "Nihongo(Japanese)"
 107
 108     $t = Template->new(
 109         -fpath => './foo.html',
 110         -lang  => 'en');
 111     print $t->str; # this shows "This is default"
 112
 113 =back
 114
 115 =back
 116
 117 =cut
 118
 119 sub new {
 120     # %args = (
 121     #   -fpath => テンプレートとして使用するファイル
 122     #   -data  => テンプレートとして使用するデータ
 123     #   -strip => <!begin>や<!end>の直後の改行を削除するかどうか,
 124     #   -lang  => 言語名,
 125     # )
 126     my ($class, %args) = @_;
 127     my $this = {
 128         original => undef, # リーフを<!mark:foo>に置換した中身。
 129         current  => undef, # <&foo>を置換した後のもの。
 130         leaves   => {},    # {名前 => Template}
 131         parent   => undef, # これがトップレベルでなければ、親(Template)。
 132         leafname => undef, # これがトップレベルでなければ、リーフ名。
 133     };
 134     bless $this => $class;
 135
 136     my $source;
 137     if (defined $args{-fpath}) {
 138         if (defined $args{-data}) {
 139             croak "You can't specify both of -fpath and -data at the same time.\n";
 140         }
 141         local $/ = undef;
 142         open my $fh, '<', $args{-fpath}
 143           or croak "Failed to open file $args{-fpath}";
 144         $source = <$fh>;
 145         close($fh);
 146     }
 147     elsif (defined $args{-data}) {
 148         $source = $args{-data};
 149     }
 150     else {
 151         croak "Missing both of -fpath and -data. Read `perldoc Template'\n";
 152     }
 153
 154     # <t-block:*>や<t-lang:*>の直後が改行コードなら、それを消す。
 155     # その改行コードから始まるスペースまたはタブも、インデントと見做して消す。
 156     if ($args{-strip}) {
 157         $source =~ s{(</?t-block:.+?>|</?t-lang:.+?>)\x0d?\x0a[ \t]*}{$1}g;
 158     }
 159
 160     # 言語
 161     my $lang = 'default';
 162     if ($args{-lang} and $source =~ m/<t-lang:\Q$args{-lang}\E>/) {
 163         $lang = $args{-lang};
 164     }
 165     $source =~ s{<t-lang:(.+?)>(.+?)</t-lang:\1>}{
 166         if ($1 eq $lang) {
 167             $2;
 168         }
 169         else {
 170             '';
 171         }
 172     }seg;
 173
 174     $this->_load($source);
 175     $this;
 176 }
 177
 178 sub reset {
 179     my $this = shift;
 180     $this->{current} = $this->{original};
 181     $this;
 182 }
 183
 184 sub expand {
 185     # $t->expand({foo => '---' , bar => '+++'});
 186     # もしくは
 187     # $t->expand(foo => '---' , bar => '+++');
 188
 189     # このメソッドは、キー内に現われたアンダースコアを
 190     # ハイフンにフォールバックする事が出來る。
 191     # つまり、<t-tag:foo-bar>というタグを、キー名"foo_bar"で指定する事が出來る。
 192     my $this = shift;
 193     my $hash = do {
 194         if (@_ == 1 && UNIVERSAL::isa($_[0],'HASH')) {
 195             $_[0];
 196         }
 197         elsif (@_ % 2 == 0) {
 198             my %h = @_;
 199             \%h;
 200         }
 201         else {
 202             croak "Illegal argument for Template->expand";
 203         }
 204     };
 205     while (my ($key,$value) = each %$hash) {
 206         # $key,$value共にスカラー値でなければならない。
 207         # リファならエラー。
 208         if (!defined $value) {
 209             croak "Values must not be undef; key: $key";
 210         }
 211         if (ref($key) ne '') {
 212             croak "Keys and values must be scalar values: $key";
 213         }
 214         if (ref($value) ne '') {
 215             croak "Keys and values must be scalar values: $value";
 216         }
 217
 218         if ($this->{current} !~ s|<t-tag:\Q$key\E(?:\s*/)?>|$value|g) {
 219             # 無い。アンダースコアをハイフンに変えてみる。
 220             (my $tred_key = $key) =~ tr/_/-/;
 221             if ($this->{current} !~ s|<t-tag:\Q$tred_key\E(?:\s*/)?>|$value|g) {
 222                 # そのようなキーは存在しなかった。警告。
 223                 #carp "No <t-tag:$key> are in template, or you have replaced it already";
 224             }
 225         }
 226     }
 227     $this;
 228 }
 229
 230 sub add {
 231     my $this = shift;
 232
 233     # 引数があればexpandする。
 234     if (@_ > 0) {
 235         eval {
 236             $this->expand(@_);
 237         }; if ($@) {
 238             croak $@;
 239         }
 240     }
 241
 242     # 親が存在しなければcroak。
 243     if (!defined $this->{parent}) {
 244         croak "This template doesn't have its parent.";
 245     }
 246
 247     # 親の<t-mark:foo>の直前に、このリーフを挿入。
 248     my $str = $this->str;
 249     $this->{parent}{current} =~ s|(<t-mark:\Q$this->{leafname}\E(?:\s*/)?>)|$str$1|g;
 250
 251     # リセット
 252     $this->reset;
 253
 254     $this;
 255 }
 256
 257 sub str {
 258     my $this = shift;
 259     my $result = $this->{current};
 260
 261     # 未置換の<t-tag:foo>があればそれを消してcarp。
 262     while ($result =~ s/(<t-tag:.+?>)//) {
 263         carp "Unexpanded tag: $1";
 264     }
 265
 266     # <t-mark:foo>を消す。
 267     $result =~ s/<t-mark:.+?>//g;
 268
 269     $result;
 270 }
 271
 272 sub leaf {
 273     my ($this,$leafname) = @_;
 274     $this->{leaves}{$leafname};
 275 }
 276
 277 sub AUTOLOAD {
 278     my $this = shift;
 279     (my $leafname = $AUTOLOAD) =~ s/.+?:://g;
 280
 281     # 余分な引數が付いてゐれば、恐らくこれは關數名の誤り。
 282     if (@_) {
 283         croak "Calling autoloaded Template->$leafname with extra arguments must be a mistake";
 284     }
 285
 286     # アンダースコアはハイフンに置換。
 287     $leafname =~ tr/_/-/;
 288     $this->{leaves}{$leafname};
 289 }
 290
 291 sub _new_leaf {
 292     my ($class,$parent,$leafname,$source) = @_;
 293     my $this = {
 294         original => undef,
 295         current => undef,
 296         leaves => {},
 297         parent => $parent,
 298         leafname => $leafname,
 299     };
 300     bless $this,$class;
 301
 302     $this->_load($source);
 303 }
 304
 305 sub _load {
 306     my ($this,$source) = @_;
 307
 308     # <t-block:foo> ... </t-block:foo>を<t-mark:foo>に置換しつつ、そのリーフを保存。
 309     while ($source =~ s|<t-block:(.+?)>(.+?)</t-block:\1>|<t-mark:$1>|s) {
 310         my ($leafname,$source) = ($1,$2);
 311
 312         if (defined $this->{leaves}{$leafname}) {
 313             # 既にこのリーフが定義されていたらcroak。
 314             croak "duplicated leaves in template: $leafname";
 315         }
 316         else {
 317             $this->{leaves}{$leafname} = __PACKAGE__->_new_leaf($this,$leafname,$source);
 318         }
 319     }
 320     $this->{original} = $this->{current} = $source;
 321
 322     $this;
 323 }
 324
 325 sub escape_tag {
 326     my @args = @_;
 327     my @result;
 328     foreach my $str (@args) {
 329         if (defined $str) {
 330             $str =~ s/\&/\&amp;/g;
 331             $str =~ s/</\&lt;/g;
 332             $str =~ s/>/\&gt;/g;
 333             $str =~ s/\"/\&quot;/g;
 334         }
 335         push @result, $str;
 336     }
 337     wantarray ? @result : $result[0];
 338 }
 339
 340 sub unescape_tag {
 341     my @args = @_;
 342     my @result;
 343     foreach my $str (@args) {
 344         if (defined $str) {
 345             $str =~ s/\&lt;/</g;
 346             $str =~ s/\&gt;/>/g;
 347             $str =~ s/\&quot;/\"/g;
 348             $str =~ s/\&amp;/\&/g;
 349         }
 350         push @result, $str;
 351     }
 352     wantarray ? @result : $result[0];
 353 }
 354
 355 sub html2tag {
 356     my $tag = {};
 357     $_ = shift;
 358
 359     s|^<||;
 360     s|^(/?\w+)|| and $tag->{__top} = lc $1;
 361
 362     while (1) {
 363         s|([\w\-]+)=([\"\'])(.*?)\2|| and do {
 364             $tag->{lc $1} = $3;
 365             next;
 366         };
 367         s|([\w\-]+)=([^\s\>]+)|| and do {
 368             $tag->{lc $1} = $2;
 369             next;
 370         };
 371         s,(\w+|/),, and do {
 372             $tag->{__end} = lc $1;
 373             next;
 374         };
 375         last;
 376     }
 377
 378     my $new = {};
 379     foreach (keys %$tag) {
 380         $new->{unescape_tag($_)} = unescape_tag($tag->{$_});
 381     }
 382     $new;
 383 }
 384
 385 sub tag2html {
 386     my $tag = shift;
 387
 388     my $html;
 389     $html .= '<' . $tag->{__top};
 390     foreach (keys %$tag) {
 391         /^__/ and next;
 392         $html .= sprintf ' %s="%s"', escape_tag($_), escape_tag($tag->{$_});
 393     }
 394     defined $tag->{__end} and
 395       $html .= ' ' . $tag->{__end};
 396
 397     $html .= '>';
 398     $html;
 399 }
 400
 401 sub setform {
 402     # $uri: URI
 403     my ($this, $uri, $name) = @_;
 404     defined $name or $name = '';
 405
 406     if (!UNIVERSAL::isa($uri, 'URI')) {
 407         croak "Usage: Template->setform(URI [, name])";
 408     }
 409
 410     $SETFORM_SUPPORTED or
 411       croak "Install URI::QueryParam to enable setform";
 412
 413     my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
 414
 415     my $outhtml = '';
 416     my $in_select; # name
 417     my $in_select_option_tag; # tag
 418     my $in_textarea; # name
 419     my $in_form = ''; # name
 420     foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
 421         if (defined $in_select and defined $in_select_option_tag) {
 422             my $value = '';
 423             /^([^ \<\r\n]*)/i and $value = $1;
 424
 425             my $tag = $in_select_option_tag;
 426             if (grep {$value eq $_} $uri->query_param($in_select)) {
 427                 $tag->{$is_xhtml ? 'selected' : '__end'} = 'selected';
 428             }
 429             else {
 430                 delete $tag->{$is_xhtml ? 'selected' : '__end'};
 431             }
 432
 433             $outhtml .= tag2html($tag);
 434             undef $in_select_option_tag;
 435         }
 436         if (defined $in_textarea) {
 437             if (!m|^</textarea>|i) {
 438                 next;
 439             }
 440         }
 441
 442         my $taghtml = $_;
 443         if (!/^</) {
 444             $outhtml .= $_;
 445             next;
 446         }
 447
 448         my $tag = html2tag($taghtml);
 449         if (!defined $tag->{__top}) {
 450             $outhtml .= $taghtml;
 451         }
 452         elsif ($tag->{__top} eq 'form') {
 453             if (defined($_ = $tag->{name})) {
 454                 $in_form = unescape_tag($_);
 455             }
 456             else {
 457                 $in_form = '';
 458             }
 459
 460             if (!$tag->{action}) {
 461                 my $act = $uri->clone;
 462                 $act->query(undef);
 463                 $act->fragment(undef);
 464                 $tag->{action} = $act->canonical->as_string;
 465             }
 466
 467             $outhtml .= tag2html($tag);
 468         }
 469         elsif ($name ne $in_form) {
 470             $outhtml .= $taghtml;
 471         }
 472         elsif ($tag->{__top} eq 'input') {
 473             if (defined $tag->{name}) {
 474                 my $type = $tag->{type};
 475                 if (!$type or
 476                       grep {$_ eq $type} qw[text password hidden submit]) {
 477                     if (defined(my $value = $uri->query_param($tag->{name}))) {
 478                         $tag->{value} = $value;
 479                     }
 480                     $outhtml .= tag2html($tag);
 481                 }
 482                 elsif (grep {$_ eq $type} qw[radio checkbox]) {
 483                     if (defined $tag->{value} and
 484                           grep {$_ eq $tag->{value}}
 485                             $uri->query_param($tag->{name})) {
 486                         $tag->{$is_xhtml ? 'checked' : '__end'} = 'checked';
 487                     }
 488                     else {
 489                         delete $tag->{$is_xhtml ? 'checked' : '__end'};
 490                     }
 491                     $outhtml .= tag2html($tag);
 492                 }
 493                 else {
 494                     $outhtml .= $taghtml;
 495                 }
 496             }
 497             else {
 498                 $outhtml .= $taghtml;
 499             }
 500         }
 501         elsif ($tag->{__top} eq 'textarea') {
 502             if (defined($_ = $tag->{name})) {
 503                 $in_textarea = $_;
 504                 $outhtml .= tag2html($tag);
 505                 if (defined(my $value = $uri->query_param($_))) {
 506                     $outhtml .= escape_tag($value);
 507                 }
 508             }
 509             else {
 510                 $outhtml .= tag2html($tag);
 511             }
 512         }
 513         elsif ($tag->{__top} eq '/textarea') {
 514             $outhtml .= tag2html($tag);
 515             undef $in_textarea;
 516         }
 517         elsif ($tag->{__top} eq 'select') {
 518             if (defined($_ = $tag->{name})) {
 519                 $in_select = $_;
 520             }
 521             $outhtml .= tag2html($tag);
 522         }
 523         elsif ($tag->{__top} eq '/select') {
 524             $outhtml .= tag2html($tag);
 525             undef $in_select;
 526         }
 527         elsif (defined $in_select) {
 528             if ($tag->{__top} eq 'option') {
 529                 if (defined(my $val = $tag->{value})) {
 530                     if (grep {$val eq $_} $uri->query_param($in_select)) {
 531                         $tag->{$is_xhtml ? 'selected' : '__end'} = 'selected';
 532                     }
 533                     else {
 534                         delete $tag->{$is_xhtml ? 'selected' : '__end'};
 535                     }
 536                     $outhtml .= tag2html($tag);
 537                 }
 538                 else {
 539                     $in_select_option_tag = $tag;
 540                 }
 541             }
 542             else {
 543                 $outhtml .= $taghtml;
 544             }
 545         }
 546         else {
 547             $outhtml .= $taghtml;
 548         }
 549     }
 550
 551     $this->{current} = $outhtml;
 552 }
 553
 554 sub addhiddenform {
 555     # $uri: URI or HASH
 556     my ($this, $uri, $name) = @_;
 557     defined $name or $name = '';
 558
 559     $SETFORM_SUPPORTED or
 560       croak "Install URI::QueryParam to enable setform";
 561
 562     if (!UNIVERSAL::isa($uri, 'URI')) {
 563         if (UNIVERSAL::isa($uri, 'HASH')) {
 564             my $u = URI->new('', 'http');
 565             while (my ($key, $value) = each %$uri) {
 566                 $u->query_param(
 567                     $key => UNIVERSAL::isa($value, 'ARRAY') ? @$value : $value);
 568             }
 569             $uri = $u;
 570         }
 571         else {
 572             croak "\$uri was not URI nor HASH";
 573         }
 574     }
 575
 576     my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
 577
 578     my $outhtml = '';
 579     foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
 580         my $taghtml = $_;
 581         if (!/^</) {
 582             $outhtml .= $_;
 583             next;
 584         }
 585
 586         my $tag = html2tag($taghtml);
 587
 588         if (defined $tag->{__top} and
 589               $tag->{__top} eq 'form' and
 590                 !$tag->{action}) {
 591             my $act = $uri->clone;
 592             $act->query(undef);
 593             $act->fragment(undef);
 594             $tag->{action} = $act->canonical->as_string;
 595
 596             $outhtml .= tag2html($tag);
 597         }
 598         else {
 599             $outhtml .= $taghtml;
 600         }
 601
 602         if (defined $tag->{__top} and
 603               $tag->{__top} eq 'form') {
 604             if ((!defined $tag->{name} and $name eq '') or
 605                   (defined $tag->{name} and $name eq $tag->{name})) {
 606                 foreach my $key ($uri->query_param) {
 607                     my $format = $is_xhtml ?
 608                       q{<input type="hidden" name="%s" value="%s" />} :
 609                         q{<input type="hidden" name="%s" value="%s">};
 610                     $outhtml .= sprintf($format, $key, $uri->query_param($key));
 611                 }
 612             }
 613         }
 614     }
 615
 616     $this->{current} = $outhtml;
 617 }
 618
 619 sub disableform {
 620     my ($this, $keylist, $name) = @_;
 621     defined $name or $name = '';
 622
 623     my %keyhash = map {$_ => 1} @$keylist;
 624
 625     my $is_xhtml = ($this->{current} =~ m|^\s*<\?xml|);
 626
 627     my $outhtml = '';
 628     my $in_textarea; # name
 629     my $in_form = '';
 630     foreach (split /(<[^\<\>]+?>)/, $this->{current}) {
 631         my $taghtml = $_;
 632         if (!/^</) {
 633             $outhtml .= $_;
 634             next;
 635         }
 636
 637         if (defined $in_textarea) {
 638             if (!m|^</textarea>|i) {
 639                 next;
 640             }
 641         }
 642
 643         my $tag = html2tag($taghtml);
 644
 645         if (!defined $tag->{__top}) {
 646             $outhtml .= $taghtml;
 647         }
 648         elsif ($tag->{__top} eq 'form') {
 649             if (defined($_ = $tag->{name})) {
 650                 $in_form = unescape_tag($_);
 651             }
 652             else {
 653                 $in_form = '';
 654             }
 655
 656             $outhtml .= tag2html($tag);
 657         }
 658         elsif ($name ne $in_form) {
 659             $outhtml .= $taghtml;
 660         }
 661         elsif ($tag->{__top} eq 'textarea') {
 662             $in_textarea = 1;
 663             $outhtml .= tag2html($tag);
 664         }
 665         elsif ($tag->{__top} eq '/textarea') {
 666             $outhtml .= tag2html($tag);
 667             undef $in_textarea;
 668         }
 669         elsif ($tag->{__top} eq 'input' or
 670                  $tag->{__top} eq 'select' or
 671                    $tag->{__top} eq 'textarea') {
 672
 673             my $name = $tag->{name};
 674             if ($name and $keyhash{$name}) {
 675                 # disable this
 676                 $tag->{$is_xhtml ? 'disabled' : '__end'} = 'disabled';
 677
 678                 # nameを消したいところだが、多分消した時の動作は實裝依存になる。
 679                 # 代はりにnameを別の名前に變換する。
 680                 $tag->{name} = sprintf 'DiSaBLeD_%s_DiSaBLeD', $tag->{name};
 681             }
 682
 683             $outhtml .= tag2html($tag);
 684         }
 685         else {
 686             $outhtml .= $taghtml;
 687         }
 688     }
 689
 690     $this->{current} = $outhtml;
 691 }
 692
 693 1;