1#================================================================= -*-Perl-*- 2# 3# Template::Directive 4# 5# DESCRIPTION 6# Factory module for constructing templates from Perl code. 7# 8# AUTHOR 9# Andy Wardley <abw@wardley.org> 10# 11# WARNING 12# Much of this module is hairy, even furry in places. It needs 13# a lot of tidying up and may even be moved into a different place 14# altogether. The generator code is often inefficient, particulary in 15# being very anal about pretty-printing the Perl code all neatly, but 16# at the moment, that's still high priority for the sake of easier 17# debugging. 18# 19# COPYRIGHT 20# Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. 21# 22# This module is free software; you can redistribute it and/or 23# modify it under the same terms as Perl itself. 24# 25#============================================================================ 26 27package Template::Directive; 28 29use strict; 30use warnings; 31use base 'Template::Base'; 32use Template::Constants; 33use Template::Exception; 34 35our $VERSION = 2.20; 36our $DEBUG = 0 unless defined $DEBUG; 37our $WHILE_MAX = 1000 unless defined $WHILE_MAX; 38our $PRETTY = 0 unless defined $PRETTY; 39our $OUTPUT = '$output .= '; 40 41 42sub _init { 43 my ($self, $config) = @_; 44 $self->{ NAMESPACE } = $config->{ NAMESPACE }; 45 return $self; 46} 47 48sub trace_vars { 49 my $self = shift; 50 return @_ 51 ? ($self->{ TRACE_VARS } = shift) 52 : $self->{ TRACE_VARS }; 53} 54 55sub pad { 56 my ($text, $pad) = @_; 57 $pad = ' ' x ($pad * 4); 58 $text =~ s/^(?!#line)/$pad/gm; 59 $text; 60} 61 62#======================================================================== 63# FACTORY METHODS 64# 65# These methods are called by the parser to construct directive instances. 66#======================================================================== 67 68#------------------------------------------------------------------------ 69# template($block) 70#------------------------------------------------------------------------ 71 72sub template { 73 my ($self, $block) = @_; 74 $block = pad($block, 2) if $PRETTY; 75 76 return "sub { return '' }" unless $block =~ /\S/; 77 78 return <<EOF; 79sub { 80 my \$context = shift || die "template sub called without context\\n"; 81 my \$stash = \$context->stash; 82 my \$output = ''; 83 my \$_tt_error; 84 85 eval { BLOCK: { 86$block 87 } }; 88 if (\$@) { 89 \$_tt_error = \$context->catch(\$@, \\\$output); 90 die \$_tt_error unless \$_tt_error->type eq 'return'; 91 } 92 93 return \$output; 94} 95EOF 96} 97 98 99#------------------------------------------------------------------------ 100# anon_block($block) [% BLOCK %] ... [% END %] 101#------------------------------------------------------------------------ 102 103sub anon_block { 104 my ($self, $block) = @_; 105 $block = pad($block, 2) if $PRETTY; 106 107 return <<EOF; 108 109# BLOCK 110$OUTPUT do { 111 my \$output = ''; 112 my \$_tt_error; 113 114 eval { BLOCK: { 115$block 116 } }; 117 if (\$@) { 118 \$_tt_error = \$context->catch(\$@, \\\$output); 119 die \$_tt_error unless \$_tt_error->type eq 'return'; 120 } 121 122 \$output; 123}; 124EOF 125} 126 127 128#------------------------------------------------------------------------ 129# block($blocktext) 130#------------------------------------------------------------------------ 131 132sub block { 133 my ($self, $block) = @_; 134 return join("\n", @{ $block || [] }); 135} 136 137 138#------------------------------------------------------------------------ 139# textblock($text) 140#------------------------------------------------------------------------ 141 142sub textblock { 143 my ($self, $text) = @_; 144 return "$OUTPUT " . &text($self, $text) . ';'; 145} 146 147 148#------------------------------------------------------------------------ 149# text($text) 150#------------------------------------------------------------------------ 151 152sub text { 153 my ($self, $text) = @_; 154 for ($text) { 155 s/(["\$\@\\])/\\$1/g; 156 s/\n/\\n/g; 157 } 158 return '"' . $text . '"'; 159} 160 161 162#------------------------------------------------------------------------ 163# quoted(\@items) "foo$bar" 164#------------------------------------------------------------------------ 165 166sub quoted { 167 my ($self, $items) = @_; 168 return '' unless @$items; 169 return ("('' . " . $items->[0] . ')') if scalar @$items == 1; 170 return '(' . join(' . ', @$items) . ')'; 171# my $r = '(' . join(' . ', @$items) . ' . "")'; 172# print STDERR "[$r]\n"; 173# return $r; 174} 175 176 177#------------------------------------------------------------------------ 178# ident(\@ident) foo.bar(baz) 179#------------------------------------------------------------------------ 180 181sub ident { 182 my ($self, $ident) = @_; 183 return "''" unless @$ident; 184 my $ns; 185 186 # Careful! Template::Parser always creates a Template::Directive object 187 # (as of v2.22_1) so $self is usually an object. However, we used to 188 # allow Template::Directive methods to be called as class methods and 189 # Template::Namespace::Constants module takes advantage of this fact 190 # by calling Template::Directive->ident() when it needs to generate an 191 # identifier. This hack guards against Mr Fuckup from coming to town 192 # when that happens. 193 194 if (ref $self) { 195 # trace variable usage 196 if ($self->{ TRACE_VARS }) { 197 my $root = $self->{ TRACE_VARS }; 198 my $n = 0; 199 my $v; 200 while ($n < @$ident) { 201 $v = $ident->[$n]; 202 for ($v) { s/^'//; s/'$// }; 203 $root = $root->{ $v } ||= { }; 204 $n += 2; 205 } 206 } 207 208 # does the first element of the identifier have a NAMESPACE 209 # handler defined? 210 if (@$ident > 2 && ($ns = $self->{ NAMESPACE })) { 211 my $key = $ident->[0]; 212 $key =~ s/^'(.+)'$/$1/s; 213 if ($ns = $ns->{ $key }) { 214 return $ns->ident($ident); 215 } 216 } 217 } 218 219 if (scalar @$ident <= 2 && ! $ident->[1]) { 220 $ident = $ident->[0]; 221 } 222 else { 223 $ident = '[' . join(', ', @$ident) . ']'; 224 } 225 return "\$stash->get($ident)"; 226} 227 228#------------------------------------------------------------------------ 229# identref(\@ident) \foo.bar(baz) 230#------------------------------------------------------------------------ 231 232sub identref { 233 my ($self, $ident) = @_; 234 return "''" unless @$ident; 235 if (scalar @$ident <= 2 && ! $ident->[1]) { 236 $ident = $ident->[0]; 237 } 238 else { 239 $ident = '[' . join(', ', @$ident) . ']'; 240 } 241 return "\$stash->getref($ident)"; 242} 243 244 245#------------------------------------------------------------------------ 246# assign(\@ident, $value, $default) foo = bar 247#------------------------------------------------------------------------ 248 249sub assign { 250 my ($self, $var, $val, $default) = @_; 251 252 if (ref $var) { 253 if (scalar @$var == 2 && ! $var->[1]) { 254 $var = $var->[0]; 255 } 256 else { 257 $var = '[' . join(', ', @$var) . ']'; 258 } 259 } 260 $val .= ', 1' if $default; 261 return "\$stash->set($var, $val)"; 262} 263 264 265#------------------------------------------------------------------------ 266# args(\@args) foo, bar, baz = qux 267#------------------------------------------------------------------------ 268 269sub args { 270 my ($self, $args) = @_; 271 my $hash = shift @$args; 272 push(@$args, '{ ' . join(', ', @$hash) . ' }') 273 if @$hash; 274 275 return '0' unless @$args; 276 return '[ ' . join(', ', @$args) . ' ]'; 277} 278 279#------------------------------------------------------------------------ 280# filenames(\@names) 281#------------------------------------------------------------------------ 282 283sub filenames { 284 my ($self, $names) = @_; 285 if (@$names > 1) { 286 $names = '[ ' . join(', ', @$names) . ' ]'; 287 } 288 else { 289 $names = shift @$names; 290 } 291 return $names; 292} 293 294 295#------------------------------------------------------------------------ 296# get($expr) [% foo %] 297#------------------------------------------------------------------------ 298 299sub get { 300 my ($self, $expr) = @_; 301 return "$OUTPUT $expr;"; 302} 303 304 305#------------------------------------------------------------------------ 306# call($expr) [% CALL bar %] 307#------------------------------------------------------------------------ 308 309sub call { 310 my ($self, $expr) = @_; 311 $expr .= ';'; 312 return $expr; 313} 314 315 316#------------------------------------------------------------------------ 317# set(\@setlist) [% foo = bar, baz = qux %] 318#------------------------------------------------------------------------ 319 320sub set { 321 my ($self, $setlist) = @_; 322 my $output; 323 while (my ($var, $val) = splice(@$setlist, 0, 2)) { 324 $output .= &assign($self, $var, $val) . ";\n"; 325 } 326 chomp $output; 327 return $output; 328} 329 330 331#------------------------------------------------------------------------ 332# default(\@setlist) [% DEFAULT foo = bar, baz = qux %] 333#------------------------------------------------------------------------ 334 335sub default { 336 my ($self, $setlist) = @_; 337 my $output; 338 while (my ($var, $val) = splice(@$setlist, 0, 2)) { 339 $output .= &assign($self, $var, $val, 1) . ";\n"; 340 } 341 chomp $output; 342 return $output; 343} 344 345 346#------------------------------------------------------------------------ 347# insert(\@nameargs) [% INSERT file %] 348# # => [ [ $file, ... ], \@args ] 349#------------------------------------------------------------------------ 350 351sub insert { 352 my ($self, $nameargs) = @_; 353 my ($file, $args) = @$nameargs; 354 $file = $self->filenames($file); 355 return "$OUTPUT \$context->insert($file);"; 356} 357 358 359#------------------------------------------------------------------------ 360# include(\@nameargs) [% INCLUDE template foo = bar %] 361# # => [ [ $file, ... ], \@args ] 362#------------------------------------------------------------------------ 363 364sub include { 365 my ($self, $nameargs) = @_; 366 my ($file, $args) = @$nameargs; 367 my $hash = shift @$args; 368 $file = $self->filenames($file); 369 $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; 370 return "$OUTPUT \$context->include($file);"; 371} 372 373 374#------------------------------------------------------------------------ 375# process(\@nameargs) [% PROCESS template foo = bar %] 376# # => [ [ $file, ... ], \@args ] 377#------------------------------------------------------------------------ 378 379sub process { 380 my ($self, $nameargs) = @_; 381 my ($file, $args) = @$nameargs; 382 my $hash = shift @$args; 383 $file = $self->filenames($file); 384 $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; 385 return "$OUTPUT \$context->process($file);"; 386} 387 388 389#------------------------------------------------------------------------ 390# if($expr, $block, $else) [% IF foo < bar %] 391# ... 392# [% ELSE %] 393# ... 394# [% END %] 395#------------------------------------------------------------------------ 396 397sub if { 398 my ($self, $expr, $block, $else) = @_; 399 my @else = $else ? @$else : (); 400 $else = pop @else; 401 $block = pad($block, 1) if $PRETTY; 402 403 my $output = "if ($expr) {\n$block\n}\n"; 404 405 foreach my $elsif (@else) { 406 ($expr, $block) = @$elsif; 407 $block = pad($block, 1) if $PRETTY; 408 $output .= "elsif ($expr) {\n$block\n}\n"; 409 } 410 if (defined $else) { 411 $else = pad($else, 1) if $PRETTY; 412 $output .= "else {\n$else\n}\n"; 413 } 414 415 return $output; 416} 417 418 419#------------------------------------------------------------------------ 420# foreach($target, $list, $args, $block) [% FOREACH x = [ foo bar ] %] 421# ... 422# [% END %] 423#------------------------------------------------------------------------ 424 425sub foreach { 426 my ($self, $target, $list, $args, $block, $label) = @_; 427 $args = shift @$args; 428 $args = @$args ? ', { ' . join(', ', @$args) . ' }' : ''; 429 $label ||= 'LOOP'; 430 431 my ($loop_save, $loop_set, $loop_restore, $setiter); 432 if ($target) { 433 $loop_save = 'eval { $_tt_oldloop = ' . &ident($self, ["'loop'"]) . ' }'; 434 $loop_set = "\$stash->{'$target'} = \$_tt_value"; 435 $loop_restore = "\$stash->set('loop', \$_tt_oldloop)"; 436 } 437 else { 438 $loop_save = '$stash = $context->localise()'; 439# $loop_set = "\$stash->set('import', \$_tt_value) " 440# . "if ref \$value eq 'HASH'"; 441 $loop_set = "\$stash->get(['import', [\$_tt_value]]) " 442 . "if ref \$_tt_value eq 'HASH'"; 443 $loop_restore = '$stash = $context->delocalise()'; 444 } 445 $block = pad($block, 3) if $PRETTY; 446 447 return <<EOF; 448 449# FOREACH 450do { 451 my (\$_tt_value, \$_tt_error, \$_tt_oldloop); 452 my \$_tt_list = $list; 453 454 unless (UNIVERSAL::isa(\$_tt_list, 'Template::Iterator')) { 455 \$_tt_list = Template::Config->iterator(\$_tt_list) 456 || die \$Template::Config::ERROR, "\\n"; 457 } 458 459 (\$_tt_value, \$_tt_error) = \$_tt_list->get_first(); 460 $loop_save; 461 \$stash->set('loop', \$_tt_list); 462 eval { 463$label: while (! \$_tt_error) { 464 $loop_set; 465$block; 466 (\$_tt_value, \$_tt_error) = \$_tt_list->get_next(); 467 } 468 }; 469 $loop_restore; 470 die \$@ if \$@; 471 \$_tt_error = 0 if \$_tt_error && \$_tt_error eq Template::Constants::STATUS_DONE; 472 die \$_tt_error if \$_tt_error; 473}; 474EOF 475} 476 477#------------------------------------------------------------------------ 478# next() [% NEXT %] 479# 480# Next iteration of a FOREACH loop (experimental) 481#------------------------------------------------------------------------ 482 483sub next { 484 my ($self, $label) = @_; 485 $label ||= 'LOOP'; 486 return <<EOF; 487(\$_tt_value, \$_tt_error) = \$_tt_list->get_next(); 488next $label; 489EOF 490} 491 492 493#------------------------------------------------------------------------ 494# wrapper(\@nameargs, $block) [% WRAPPER template foo = bar %] 495# # => [ [$file,...], \@args ] 496#------------------------------------------------------------------------ 497 498sub wrapper { 499 my ($self, $nameargs, $block) = @_; 500 my ($file, $args) = @$nameargs; 501 my $hash = shift @$args; 502 503 local $" = ', '; 504# print STDERR "wrapper([@$file], { @$hash })\n"; 505 506 return $self->multi_wrapper($file, $hash, $block) 507 if @$file > 1; 508 $file = shift @$file; 509 510 $block = pad($block, 1) if $PRETTY; 511 push(@$hash, "'content'", '$output'); 512 $file .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; 513 514 return <<EOF; 515 516# WRAPPER 517$OUTPUT do { 518 my \$output = ''; 519$block 520 \$context->include($file); 521}; 522EOF 523} 524 525 526sub multi_wrapper { 527 my ($self, $file, $hash, $block) = @_; 528 $block = pad($block, 1) if $PRETTY; 529 530 push(@$hash, "'content'", '$output'); 531 $hash = @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; 532 533 $file = join(', ', reverse @$file); 534# print STDERR "multi wrapper: $file\n"; 535 536 return <<EOF; 537 538# WRAPPER 539$OUTPUT do { 540 my \$output = ''; 541$block 542 foreach ($file) { 543 \$output = \$context->include(\$_$hash); 544 } 545 \$output; 546}; 547EOF 548} 549 550 551#------------------------------------------------------------------------ 552# while($expr, $block) [% WHILE x < 10 %] 553# ... 554# [% END %] 555#------------------------------------------------------------------------ 556 557sub while { 558 my ($self, $expr, $block, $label) = @_; 559 $block = pad($block, 2) if $PRETTY; 560 $label ||= 'LOOP'; 561 562 return <<EOF; 563 564# WHILE 565do { 566 my \$_tt_failsafe = $WHILE_MAX; 567$label: 568 while (--\$_tt_failsafe && ($expr)) { 569$block 570 } 571 die "WHILE loop terminated (> $WHILE_MAX iterations)\\n" 572 unless \$_tt_failsafe; 573}; 574EOF 575} 576 577 578#------------------------------------------------------------------------ 579# switch($expr, \@case) [% SWITCH %] 580# [% CASE foo %] 581# ... 582# [% END %] 583#------------------------------------------------------------------------ 584 585sub switch { 586 my ($self, $expr, $case) = @_; 587 my @case = @$case; 588 my ($match, $block, $default); 589 my $caseblock = ''; 590 591 $default = pop @case; 592 593 foreach $case (@case) { 594 $match = $case->[0]; 595 $block = $case->[1]; 596 $block = pad($block, 1) if $PRETTY; 597 $caseblock .= <<EOF; 598\$_tt_match = $match; 599\$_tt_match = [ \$_tt_match ] unless ref \$_tt_match eq 'ARRAY'; 600if (grep(/^\\Q\$_tt_result\\E\$/, \@\$_tt_match)) { 601$block 602 last SWITCH; 603} 604EOF 605 } 606 607 $caseblock .= $default 608 if defined $default; 609 $caseblock = pad($caseblock, 2) if $PRETTY; 610 611return <<EOF; 612 613# SWITCH 614do { 615 my \$_tt_result = $expr; 616 my \$_tt_match; 617 SWITCH: { 618$caseblock 619 } 620}; 621EOF 622} 623 624 625#------------------------------------------------------------------------ 626# try($block, \@catch) [% TRY %] 627# ... 628# [% CATCH %] 629# ... 630# [% END %] 631#------------------------------------------------------------------------ 632 633sub try { 634 my ($self, $block, $catch) = @_; 635 my @catch = @$catch; 636 my ($match, $mblock, $default, $final, $n); 637 my $catchblock = ''; 638 my $handlers = []; 639 640 $block = pad($block, 2) if $PRETTY; 641 $final = pop @catch; 642 $final = "# FINAL\n" . ($final ? "$final\n" : '') 643 . 'die $_tt_error if $_tt_error;' . "\n" . '$output;'; 644 $final = pad($final, 1) if $PRETTY; 645 646 $n = 0; 647 foreach $catch (@catch) { 648 $match = $catch->[0] || do { 649 $default ||= $catch->[1]; 650 next; 651 }; 652 $mblock = $catch->[1]; 653 $mblock = pad($mblock, 1) if $PRETTY; 654 push(@$handlers, "'$match'"); 655 $catchblock .= $n++ 656 ? "elsif (\$_tt_handler eq '$match') {\n$mblock\n}\n" 657 : "if (\$_tt_handler eq '$match') {\n$mblock\n}\n"; 658 } 659 $catchblock .= "\$_tt_error = 0;"; 660 $catchblock = pad($catchblock, 3) if $PRETTY; 661 if ($default) { 662 $default = pad($default, 1) if $PRETTY; 663 $default = "else {\n # DEFAULT\n$default\n \$_tt_error = '';\n}"; 664 } 665 else { 666 $default = '# NO DEFAULT'; 667 } 668 $default = pad($default, 2) if $PRETTY; 669 670 $handlers = join(', ', @$handlers); 671return <<EOF; 672 673# TRY 674$OUTPUT do { 675 my \$output = ''; 676 my (\$_tt_error, \$_tt_handler); 677 eval { 678$block 679 }; 680 if (\$@) { 681 \$_tt_error = \$context->catch(\$@, \\\$output); 682 die \$_tt_error if \$_tt_error->type =~ /^return|stop\$/; 683 \$stash->set('error', \$_tt_error); 684 \$stash->set('e', \$_tt_error); 685 if (defined (\$_tt_handler = \$_tt_error->select_handler($handlers))) { 686$catchblock 687 } 688$default 689 } 690$final 691}; 692EOF 693} 694 695 696#------------------------------------------------------------------------ 697# throw(\@nameargs) [% THROW foo "bar error" %] 698# # => [ [$type], \@args ] 699#------------------------------------------------------------------------ 700 701sub throw { 702 my ($self, $nameargs) = @_; 703 my ($type, $args) = @$nameargs; 704 my $hash = shift(@$args); 705 my $info = shift(@$args); 706 $type = shift @$type; # uses same parser production as INCLUDE 707 # etc., which allow multiple names 708 # e.g. INCLUDE foo+bar+baz 709 710 if (! $info) { 711 $args = "$type, undef"; 712 } 713 elsif (@$hash || @$args) { 714 local $" = ', '; 715 my $i = 0; 716 $args = "$type, { args => [ " 717 . join(', ', $info, @$args) 718 . ' ], ' 719 . join(', ', 720 (map { "'" . $i++ . "' => $_" } ($info, @$args)), 721 @$hash) 722 . ' }'; 723 } 724 else { 725 $args = "$type, $info"; 726 } 727 728 return "\$context->throw($args, \\\$output);"; 729} 730 731 732#------------------------------------------------------------------------ 733# clear() [% CLEAR %] 734# 735# NOTE: this is redundant, being hard-coded (for now) into Parser.yp 736#------------------------------------------------------------------------ 737 738sub clear { 739 return "\$output = '';"; 740} 741 742#------------------------------------------------------------------------ 743# break() [% BREAK %] 744# 745# NOTE: this is redundant, being hard-coded (for now) into Parser.yp 746#------------------------------------------------------------------------ 747 748sub OLD_break { 749 return 'last LOOP;'; 750} 751 752#------------------------------------------------------------------------ 753# return() [% RETURN %] 754#------------------------------------------------------------------------ 755 756sub return { 757 return "\$context->throw('return', '', \\\$output);"; 758} 759 760#------------------------------------------------------------------------ 761# stop() [% STOP %] 762#------------------------------------------------------------------------ 763 764sub stop { 765 return "\$context->throw('stop', '', \\\$output);"; 766} 767 768 769#------------------------------------------------------------------------ 770# use(\@lnameargs) [% USE alias = plugin(args) %] 771# # => [ [$file, ...], \@args, $alias ] 772#------------------------------------------------------------------------ 773 774sub use { 775 my ($self, $lnameargs) = @_; 776 my ($file, $args, $alias) = @$lnameargs; 777 $file = shift @$file; # same production rule as INCLUDE 778 $alias ||= $file; 779 $args = &args($self, $args); 780 $file .= ", $args" if $args; 781# my $set = &assign($self, $alias, '$plugin'); 782 return "# USE\n" 783 . "\$stash->set($alias,\n" 784 . " \$context->plugin($file));"; 785} 786 787#------------------------------------------------------------------------ 788# view(\@nameargs, $block) [% VIEW name args %] 789# # => [ [$file, ... ], \@args ] 790#------------------------------------------------------------------------ 791 792sub view { 793 my ($self, $nameargs, $block, $defblocks) = @_; 794 my ($name, $args) = @$nameargs; 795 my $hash = shift @$args; 796 $name = shift @$name; # same production rule as INCLUDE 797 $block = pad($block, 1) if $PRETTY; 798 799 if (%$defblocks) { 800 $defblocks = join(",\n", map { "'$_' => $defblocks->{ $_ }" } 801 keys %$defblocks); 802 $defblocks = pad($defblocks, 1) if $PRETTY; 803 $defblocks = "{\n$defblocks\n}"; 804 push(@$hash, "'blocks'", $defblocks); 805 } 806 $hash = @$hash ? '{ ' . join(', ', @$hash) . ' }' : ''; 807 808 return <<EOF; 809# VIEW 810do { 811 my \$output = ''; 812 my \$_tt_oldv = \$stash->get('view'); 813 my \$_tt_view = \$context->view($hash); 814 \$stash->set($name, \$_tt_view); 815 \$stash->set('view', \$_tt_view); 816 817$block 818 819 \$stash->set('view', \$_tt_oldv); 820 \$_tt_view->seal(); 821# \$output; # not used - commented out to avoid warning 822}; 823EOF 824} 825 826 827#------------------------------------------------------------------------ 828# perl($block) 829#------------------------------------------------------------------------ 830 831sub perl { 832 my ($self, $block) = @_; 833 $block = pad($block, 1) if $PRETTY; 834 835 return <<EOF; 836 837# PERL 838\$context->throw('perl', 'EVAL_PERL not set') 839 unless \$context->eval_perl(); 840 841$OUTPUT do { 842 my \$output = "package Template::Perl;\\n"; 843 844$block 845 846 local(\$Template::Perl::context) = \$context; 847 local(\$Template::Perl::stash) = \$stash; 848 849 my \$_tt_result = ''; 850 tie *Template::Perl::PERLOUT, 'Template::TieString', \\\$_tt_result; 851 my \$_tt_save_stdout = select *Template::Perl::PERLOUT; 852 853 eval \$output; 854 select \$_tt_save_stdout; 855 \$context->throw(\$@) if \$@; 856 \$_tt_result; 857}; 858EOF 859} 860 861 862#------------------------------------------------------------------------ 863# no_perl() 864#------------------------------------------------------------------------ 865 866sub no_perl { 867 my $self = shift; 868 return "\$context->throw('perl', 'EVAL_PERL not set');"; 869} 870 871 872#------------------------------------------------------------------------ 873# rawperl($block) 874# 875# NOTE: perhaps test context EVAL_PERL switch at compile time rather than 876# runtime? 877#------------------------------------------------------------------------ 878 879sub rawperl { 880 my ($self, $block, $line) = @_; 881 for ($block) { 882 s/^\n+//; 883 s/\n+$//; 884 } 885 $block = pad($block, 1) if $PRETTY; 886 $line = $line ? " (starting line $line)" : ''; 887 888 return <<EOF; 889# RAWPERL 890#line 1 "RAWPERL block$line" 891$block 892EOF 893} 894 895 896 897#------------------------------------------------------------------------ 898# filter() 899#------------------------------------------------------------------------ 900 901sub filter { 902 my ($self, $lnameargs, $block) = @_; 903 my ($name, $args, $alias) = @$lnameargs; 904 $name = shift @$name; 905 $args = &args($self, $args); 906 $args = $args ? "$args, $alias" : ", undef, $alias" 907 if $alias; 908 $name .= ", $args" if $args; 909 $block = pad($block, 1) if $PRETTY; 910 911 return <<EOF; 912 913# FILTER 914$OUTPUT do { 915 my \$output = ''; 916 my \$_tt_filter = \$context->filter($name) 917 || \$context->throw(\$context->error); 918 919$block 920 921 &\$_tt_filter(\$output); 922}; 923EOF 924} 925 926 927#------------------------------------------------------------------------ 928# capture($name, $block) 929#------------------------------------------------------------------------ 930 931sub capture { 932 my ($self, $name, $block) = @_; 933 934 if (ref $name) { 935 if (scalar @$name == 2 && ! $name->[1]) { 936 $name = $name->[0]; 937 } 938 else { 939 $name = '[' . join(', ', @$name) . ']'; 940 } 941 } 942 $block = pad($block, 1) if $PRETTY; 943 944 return <<EOF; 945 946# CAPTURE 947\$stash->set($name, do { 948 my \$output = ''; 949$block 950 \$output; 951}); 952EOF 953 954} 955 956 957#------------------------------------------------------------------------ 958# macro($name, $block, \@args) 959#------------------------------------------------------------------------ 960 961sub macro { 962 my ($self, $ident, $block, $args) = @_; 963 $block = pad($block, 2) if $PRETTY; 964 965 if ($args) { 966 my $nargs = scalar @$args; 967 $args = join(', ', map { "'$_'" } @$args); 968 $args = $nargs > 1 969 ? "\@_tt_args{ $args } = splice(\@_, 0, $nargs)" 970 : "\$_tt_args{ $args } = shift"; 971 972 return <<EOF; 973 974# MACRO 975\$stash->set('$ident', sub { 976 my \$output = ''; 977 my (%_tt_args, \$_tt_params); 978 $args; 979 \$_tt_params = shift; 980 \$_tt_params = { } unless ref(\$_tt_params) eq 'HASH'; 981 \$_tt_params = { \%_tt_args, %\$_tt_params }; 982 983 my \$stash = \$context->localise(\$_tt_params); 984 eval { 985$block 986 }; 987 \$stash = \$context->delocalise(); 988 die \$@ if \$@; 989 return \$output; 990}); 991EOF 992 993 } 994 else { 995 return <<EOF; 996 997# MACRO 998\$stash->set('$ident', sub { 999 my \$_tt_params = \$_[0] if ref(\$_[0]) eq 'HASH'; 1000 my \$output = ''; 1001 1002 my \$stash = \$context->localise(\$_tt_params); 1003 eval { 1004$block 1005 }; 1006 \$stash = \$context->delocalise(); 1007 die \$@ if \$@; 1008 return \$output; 1009}); 1010EOF 1011 } 1012} 1013 1014 1015sub debug { 1016 my ($self, $nameargs) = @_; 1017 my ($file, $args) = @$nameargs; 1018 my $hash = shift @$args; 1019 $args = join(', ', @$file, @$args); 1020 $args .= @$hash ? ', { ' . join(', ', @$hash) . ' }' : ''; 1021 return "$OUTPUT \$context->debugging($args); ## DEBUG ##"; 1022} 1023 1024 10251; 1026 1027__END__ 1028 1029=head1 NAME 1030 1031Template::Directive - Perl code generator for template directives 1032 1033=head1 SYNOPSIS 1034 1035 # no user serviceable parts inside 1036 1037=head1 DESCRIPTION 1038 1039The C<Template::Directive> module defines a number of methods that 1040generate Perl code for the runtime representation of the various 1041Template Toolkit directives. 1042 1043It is used internally by the L<Template::Parser> module. 1044 1045=head1 AUTHOR 1046 1047Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> 1048 1049=head1 COPYRIGHT 1050 1051Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. 1052 1053This module is free software; you can redistribute it and/or 1054modify it under the same terms as Perl itself. 1055 1056=head1 SEE ALSO 1057 1058L<Template::Parser> 1059 1060=cut 1061 1062# Local Variables: 1063# mode: perl 1064# perl-indent-level: 4 1065# indent-tabs-mode: nil 1066# End: 1067# 1068# vim: expandtab shiftwidth=4: 1069 1070