local-lib5/lib/perl5/i486-linux-gnu-thread-multi/Template/Directive.pm

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